Newer
Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
;;; -*- Package: HEMLOCK -*-
;;;
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/rcs.lisp,v 1.1 1990/02/06 11:43:44 wlott Exp $
;;;
;;; Various commands for dealing with RCS under hemlock.
;;;
(in-package "HEMLOCK")
(defun current-buffer-pathname ()
(let ((pathname (buffer-pathname (current-buffer))))
(unless pathname
(editor-error "The buffer has no pathname."))
pathname))
(defmacro in-directory (directory &body forms)
(let ((cwd (gensym)))
`(let ((,cwd (ext:default-directory)))
(unwind-protect
(progn
(setf (ext:default-directory) (directory-namestring ,directory))
,@forms)
(setf (ext:default-directory) ,cwd)))))
(defvar *error-stream* (make-string-output-stream))
(defmacro do-command (&rest args)
(let ((proc (gensym)))
`(progn
(get-output-stream-string *error-stream*)
(let ((,proc (ext:run-program ,@args :error *error-stream*)))
(case (ext:process-status ,proc)
(:exited
(unless (zerop (ext:process-exit-code ,proc))
(editor-error "~A" (get-output-stream-string *error-stream*))))
(:signaled
(editor-error "~A killed with signal ~A ~@[core dumped]"
',(car args)
(ext:process-exit-code ,proc)
(ext:process-core-dumped ,proc)))
(t
(editor-error "~S still alive?" ,proc)))))))
(defun buffer-different-from-file (buffer filename)
(with-open-file (file filename)
(do ((buffer-line (mark-line (buffer-start-mark buffer))
(line-next buffer-line))
(file-line (read-line file nil nil)
(read-line file nil nil)))
((and (or (null buffer-line)
(zerop (line-length buffer-line)))
(null file-line))
nil)
(when (or (null buffer-line)
(null file-line)
(string/= (line-string buffer-line) file-line))
(return t)))))
(defun rcs-lock-file (pathname)
(message "Locking ~A" (namestring pathname))
(in-directory pathname
(let ((file (file-namestring pathname)))
(do-command "rcs" `("-l" ,file))
(multiple-value-bind
(won dev ino mode)
(mach:unix-stat file)
(declare (ignore dev ino))
(when won
(mach:unix-chmod file (logior mode mach:writeown)))))))
(defun rcs-unlock-file (pathname)
(message "Unlocking ~A" (namestring pathname))
(in-directory pathname
(do-command "rcs" `("-u" ,(file-namestring pathname)))))
(defun rcs-check-in-file (pathname keep-lock)
(let ((old-buffer (current-buffer))
(allow-delete nil)
(buffer nil))
(unwind-protect
(when (block in-recursive-edit
(do ((i 0 (1+ i)))
((not (null buffer)))
(setf buffer
(make-buffer (format nil "RCS Log Entry ~D for ~S"
i (file-namestring pathname))
:modes '("Text")
:delete-hook
(list #'(lambda (buffer)
(declare (ignore buffer))
(unless allow-delete
(return-from in-recursive-edit
t)))))))
(setf (buffer-minor-mode buffer "Save") nil)
(when (getstring "Ckp" *mode-names*)
(setf (buffer-minor-mode buffer "Ckp") nil))
(change-to-buffer buffer)
(do-recursive-edit)
(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))))
nil)
(editor-error "Someone deleted the RCS Log Entry buffer."))
(change-to-buffer old-buffer)
(setf allow-delete t)
(delete-buffer buffer))))
(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)
(do-command "rcsco" `(,@(if lock '("-l")) ,(file-namestring pathname)))
(delete-file backup))))
(defun pick-temp-file (defaults)
(let ((index 0))
(loop
(let ((name (merge-pathnames (format nil ",rcstmp-~D" index) defaults)))
(cond ((probe-file name)
(incf index))
(t
(return name)))))))
(defcommand "RCS Lock Buffer File" (p)
"Attempt to lock the file in the current buffer."
"Attempt to lock the file in the current buffer."
(declare (ignore p))
(let ((file (current-buffer-pathname))
(buffer (current-buffer))
(name (pick-temp-file "/tmp/")))
(rcs-lock-file file)
(unwind-protect
(progn
(in-directory file
(do-command "rcsco" `("-p" ,(file-namestring file))
:output (namestring name)))
(when (buffer-different-from-file buffer name)
(message
"RCS file is different, be sure to merge your changes in."))
(setf (buffer-writable buffer) t)
(message "Buffer is now writable."))
(when (probe-file name)
(delete-file name)))))
(defcommand "RCS Lock File" (p)
"Prompt for a file, and attempt to lock it."
"Prompt for a file, and attempt to lock it."
(declare (ignore p))
(rcs-lock-file (prompt-for-file :prompt "File to lock: "
:default (buffer-pathname (current-buffer))
:must-exist nil)))
(defcommand "RCS Unlock Buffer File" (p)
"Unlock the file in the current buffer."
"Unlock the file in the current buffer."
(declare (ignore p))
(rcs-unlock-file (current-buffer-pathname))
(setf (buffer-writable (current-buffer)) nil)
(message "Buffer is no longer writable."))
(defcommand "RCS Unlock File" (p)
"Prompt for a file, and attempt to unlock it."
"Prompt for a file, and attempt to unlock it."
(declare (ignore p))
(rcs-unlock-file (prompt-for-file :prompt "File to unlock: "
:default (buffer-pathname (current-buffer))
:must-exist nil)))
(defcommand "RCS Check In Buffer File" (p)
"Checkin the file in the current buffer. With an argument, do not release
the lock."
"Checkin the file in the current buffer. With an argument, do not release
the lock."
(let ((buffer (current-buffer))
(pathname (current-buffer-pathname)))
(when (buffer-modified buffer)
(save-file-command nil))
(rcs-check-in-file pathname p)
(visit-file-command nil pathname buffer)))
(defcommand "RCS Check In File" (p)
"Prompt for a file, and attempt to check it in. With an argument, do not
release the lock."
"Prompt for a file, and attempt to check it in. With an argument, do not
release the lock."
(rcs-check-in-file (prompt-for-file :prompt "File to lock: "
:default
(buffer-pathname (current-buffer))
:must-exist nil)
p))
(defcommand "RCS Check Out Buffer File" (p)
"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 file."
(let* ((buffer (current-buffer))
(pathname (current-buffer-pathname))
(point (current-point))
(lines (1- (count-lines (region (buffer-start-mark buffer) point)))))
(when (buffer-modified buffer)
(when (not (prompt-for-y-or-n :prompt "Buffer is modified, overwrite? "))
(editor-error "Aborted.")))
(rcs-check-out-file pathname p)
(setf (buffer-modified buffer) nil)
(when p
(setf (buffer-writable buffer) t)
(message "Buffer is now writable."))
(visit-file-command nil pathname)
(unless (line-offset point lines)
(buffer-end point))))
(defcommand "RCS Check Out File" (p)
"Prompt for a file and attempt to check it out. With an argument, lock the
file."
"Prompt for a file and attempt to check it out. With an argument, lock the
file."
(let ((pathname (prompt-for-file :prompt "File to check out: "
:default (buffer-pathname (current-buffer))
:must-exist nil)))
(rcs-check-out-file pathname p)
(find-file-command nil pathname)))
(defhvar "RCS Log Entry Buffer"
"Name of the buffer to put RCS log entries into."
:value "RCS Log")
(defun get-log-buffer ()
(let ((buffer (getstring (value rcs-log-entry-buffer) *buffer-names*)))
(unless buffer
(setf buffer (make-buffer (value rcs-log-entry-buffer)))
(setf (buffer-minor-mode buffer "Save") nil)
(when (getstring "Ckp" *mode-names*)
(setf (buffer-minor-mode buffer "Ckp") nil)))
buffer))
(defcommand "RCS Buffer File Log Entry" (p)
"Get the RCS Log for the file in the current buffer in a buffer."
"Get the RCS Log for the file in the current buffer in a buffer."
(declare (ignore p))
(let ((buffer (get-log-buffer))
(pathname (current-buffer-pathname)))
(delete-region (buffer-region buffer))
(message "Extracing log info.")
(with-mark ((mark (buffer-start-mark buffer) :left-inserting))
(in-directory pathname
(do-command "rlog" (list (file-namestring pathname))
:output (make-hemlock-output-stream mark))))
(change-to-buffer buffer)
(buffer-start (current-point))
(setf (buffer-modified buffer) nil)))
(defcommand "RCS File Log Entry" (p)
"Prompt for a file and get it's RCS log entry in a buffer."
"Prompt for a file and get it's RCS log entry in a buffer."
(declare (ignore p))
(let ((file (prompt-for-file :prompt "File to get log of: "
:default (buffer-pathname (current-buffer))
:must-exist nil))
(buffer (get-log-buffer)))
(delete-region (buffer-region buffer))
(message "Extracing log info.")
(with-mark ((mark (buffer-start-mark buffer) :left-inserting))
(in-directory file
(do-command "rlog" (list (file-namestring file))
:output (make-hemlock-output-stream mark))))
(change-to-buffer buffer)
(buffer-start (current-point))
(setf (buffer-modified buffer) nil)))