|
0
|
1 ;;; generic-sc.el --- generic interface to source control systems
|
|
|
2
|
|
|
3 ;; Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc.
|
|
|
4
|
|
|
5 ;; Author: devin@lucid.com
|
|
|
6 ;; Keywords: tools, unix
|
|
|
7
|
|
|
8 ;; This file is part of XEmacs.
|
|
|
9
|
|
|
10 ;; XEmacs is free software; you can redistribute it and/or modify it
|
|
|
11 ;; under the terms of the GNU General Public License as published by
|
|
|
12 ;; the Free Software Foundation; either version 2, or (at your option)
|
|
|
13 ;; any later version.
|
|
|
14
|
|
|
15 ;; XEmacs is distributed in the hope that it will be useful, but
|
|
|
16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
|
18 ;; General Public License for more details.
|
|
|
19
|
|
|
20 ;; You should have received a copy of the GNU General Public License
|
|
16
|
21 ;; along with XEmacs; see the file COPYING. If not, write to the
|
|
|
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
|
23 ;; Boston, MA 02111-1307, USA.
|
|
0
|
24
|
|
|
25 ;;; Synched up with: Not in FSF.
|
|
|
26
|
|
|
27 ;; The generic interface provide a common set of functions that can be
|
|
|
28 ;; used to interface with a source control system like SCCS, RCS or
|
|
|
29 ;; CVS.
|
|
|
30 ;;
|
|
|
31 ;; You chose which source control system to use by calling sc-mode
|
|
|
32 ;;
|
|
|
33 ;; The module is based on the sccs.el mode of Eric S. Raymond
|
|
|
34 ;; (eric@snark.thyrsus.com) which was distantly derived from an rcs
|
|
|
35 ;; mode written by Ed Simpson ({decvax, seismo}!mcnc!duke!dukecdu!evs)
|
|
|
36 ;; in years gone by and revised at MIT's Project Athena.
|
|
|
37
|
|
|
38 ;;; This can be customized by the user
|
|
|
39 (defvar sc-diff-command '("diff")
|
|
|
40 "*The command/flags list to be used in constructing diff commands.")
|
|
|
41
|
|
|
42 ;; Duplicated from pcl-cvs.
|
|
|
43 (defvar cvs-program "cvs"
|
|
|
44 "*The command name of the cvs program.")
|
|
|
45
|
|
|
46 (defvar sc-mode-expert ()
|
|
|
47 "*Treat user as expert; suppress yes-no prompts on some things.")
|
|
|
48
|
|
|
49 (defvar sc-max-log-size 510
|
|
|
50 "*Maximum allowable size of a source control log message.")
|
|
|
51
|
|
|
52 (defvar sc-ccase-comment-on '(checkout checkout-dir checkin-dir rename
|
|
|
53 new-brtype new-branch checkin-merge
|
|
|
54 create-label label-sources)
|
|
|
55 "*Operations on which comments would be appreciated.
|
|
|
56 We check the values checkout, checkout-dir, checkin-dir,
|
|
|
57 rename, new-brtype, new-branch, create-label,
|
|
|
58 and label-sources as symbols.")
|
|
|
59
|
|
|
60 (defvar sc-ccase-reserve nil
|
|
|
61 "Whether to reserve checkouts or not. By default, this is nil - don't.
|
|
|
62 Other values are t - do, and anything else, eg. 'ask - ask.")
|
|
|
63
|
|
|
64 ;; default keybindings
|
|
|
65 (defvar sc-prefix-map (lookup-key global-map "\C-xv"))
|
|
|
66 (if (not (keymapp sc-prefix-map))
|
|
|
67 (progn
|
|
|
68 (setq sc-prefix-map (make-sparse-keymap))
|
|
|
69 (define-key global-map "\C-xv" sc-prefix-map)
|
|
|
70 (define-key sc-prefix-map "v" 'sc-next-operation)
|
|
|
71 (define-key sc-prefix-map "=" 'sc-show-changes)
|
|
|
72 (define-key sc-prefix-map "l" 'sc-show-history)
|
|
|
73 (define-key sc-prefix-map "p" 'sc-visit-previous-revision)
|
|
|
74 (define-key sc-prefix-map "u" 'sc-revert-file)
|
|
|
75 (define-key sc-prefix-map "d" 'sc-list-registered-files)
|
|
|
76 (define-key sc-prefix-map "\C-d" 'sc-update-directory)
|
|
|
77 (define-key sc-prefix-map "\C-r" 'sc-rename-file)
|
|
|
78 ))
|
|
|
79
|
|
|
80
|
|
|
81 ;;; The user does not change these
|
|
|
82 (defvar sc-generic-name ""
|
|
|
83 "Name of the source control system used. Is displayed in the modeline.")
|
|
|
84
|
|
|
85 (defvar sc-mode-line-string ()
|
|
|
86 "Revision number to show in the mode line")
|
|
|
87
|
|
|
88 (defvar sc-generic-log-buf ()
|
|
|
89 "Buffer for entering log message")
|
|
|
90
|
|
|
91 (defvar sc-log-entry-keymap ()
|
|
|
92 "Additional keybindings used when entering the log message")
|
|
|
93
|
|
|
94 (defvar sc-can-hack-dir ()
|
|
|
95 "Does the SC system allow users to play directly with directories")
|
|
|
96
|
|
|
97 (defvar sc-ccase-mfs-prefixes ()
|
|
|
98 "Prefixes known to the system to be MFS ... ignore all others")
|
|
|
99
|
|
|
100 (defmacro sc-chmod (perms file)
|
|
|
101 (list 'call-process "chmod" nil nil nil perms file))
|
|
|
102
|
|
|
103 (defmacro error-occurred (&rest body)
|
|
|
104 (list 'condition-case nil (cons 'progn (append body '(nil))) '(error t)))
|
|
|
105
|
|
|
106
|
|
|
107 ;;; User level functions
|
|
|
108 (defun sc-next-operation (verbose)
|
|
|
109 "Do the next logical source-control operation on the file in the current buffer.
|
|
|
110 The current subdirectory must be under source control.
|
|
|
111 If the file is not already registered with the source control, this registers it
|
|
|
112 and checks it out.
|
|
|
113 If the file is registered and not locked by anyone, this checks it out.
|
|
|
114 If the file is registered and locked by the calling user, this pops up a
|
|
|
115 buffer for creation of a log message, then checks the file in.
|
|
|
116 A read-only copy of the changed file is left in place afterwards.
|
|
|
117 If the file is registered and locked by someone else, an error message is
|
|
|
118 returned indicating who has locked it."
|
|
|
119 (interactive "P")
|
|
|
120 (if (not buffer-file-name)
|
|
|
121 (error "There is no file associated with buffer %s" (buffer-name)))
|
|
|
122 (let* (revision
|
|
|
123 (file buffer-file-name)
|
|
|
124 (lock-info (sc-lock-info file))
|
|
|
125 (sc-generic-log-buf
|
|
|
126 (get-buffer-create (format "*%s-Log*" sc-generic-name)))
|
|
|
127 (err-msg nil))
|
|
|
128 (if (eq lock-info 'na)
|
|
|
129 (error "The file associated with buffer %s is not registered" (buffer-name)))
|
|
|
130
|
|
|
131 ;; if file is not registered register it and set lock-info to show it's not locked
|
|
|
132 (if (not lock-info)
|
|
|
133 (progn
|
|
|
134 (sc-register-file verbose)
|
|
|
135 (setq lock-info (list () ()))))
|
|
|
136
|
|
|
137 (cond ((not (car lock-info))
|
|
|
138 ;; if there is no lock on the file, assert one and get it
|
|
|
139 (sc-check-out file t)
|
|
|
140 (revert-buffer nil t)
|
|
|
141 (sc-mode-line))
|
|
|
142
|
|
|
143 ((and (not (equal sc-generic-name "CCase"))
|
|
|
144 (not (equal (car lock-info) (user-login-name))))
|
|
|
145 ;; file is locked by someone else
|
|
|
146 (error "Sorry, %s has that file locked." (car lock-info)))
|
|
|
147
|
|
|
148 (t
|
|
|
149 ;; OK, user owns the lock on the file
|
|
|
150 ;; if so, give user a chance to save before delta-ing.
|
|
|
151 (if (and (buffer-modified-p)
|
|
|
152 (or
|
|
|
153 sc-mode-expert
|
|
|
154 (y-or-n-p (format "%s has been modified. Write it out? "
|
|
|
155 (buffer-name)))))
|
|
|
156 (save-buffer))
|
|
|
157
|
|
|
158 (setq revision (car (cdr lock-info)))
|
|
|
159
|
|
|
160 ;; user may want to set nonstandard parameters
|
|
|
161 (if verbose
|
|
|
162 (if (or sc-mode-expert
|
|
|
163 (y-or-n-p
|
|
|
164 (format "revision: %s Change revision level? "
|
|
|
165 revision)))
|
|
|
166 (setq revision (read-string "New revision level: "))))
|
|
|
167
|
|
|
168 ;; OK, let's do the delta
|
|
|
169 (let ((buffer (sc-temp-buffer)))
|
|
|
170 (if (save-window-excursion
|
|
|
171 ;; this excursion returns t if the new version was saved OK
|
|
|
172 (pop-to-buffer buffer)
|
|
|
173 (erase-buffer)
|
|
|
174 (set-buffer-modified-p nil)
|
|
|
175 (sc-log-entry-mode)
|
|
|
176 (message
|
|
|
177 "Enter log message. Type C-c C-c when done, C-c ? for help.")
|
|
|
178 (prog1
|
|
|
179 (and (not (error-occurred (recursive-edit)))
|
|
|
180 (not (error-occurred
|
|
|
181 (sc-check-in file revision
|
|
|
182 (buffer-string)))))
|
|
|
183 (setq buffer-file-name nil)
|
|
|
184 (bury-buffer buffer)))
|
|
|
185
|
|
|
186 ;; if the save went OK do some post-checking
|
|
|
187 (if (buffer-modified-p)
|
|
|
188 (error
|
|
|
189 "Checked-in version of file does not match buffer!")
|
|
|
190 (revert-buffer nil t)
|
|
|
191 (sc-mode-line)
|
|
|
192 (run-hooks 'sc-check-in-ok))))))))
|
|
|
193
|
|
|
194 (defun sc-insert-last-log ()
|
|
|
195 "Insert the log message of the last check in at point."
|
|
|
196 (interactive)
|
|
|
197 (insert-buffer sc-generic-log-buf))
|
|
|
198
|
|
|
199 (defun sc-abort-check-in ()
|
|
|
200 "Abort a source control check-in command."
|
|
|
201 (interactive)
|
|
|
202 (if (or sc-mode-expert (y-or-n-p "Really Abort Check-in? "))
|
|
|
203 (progn
|
|
|
204 (delete-window)
|
|
|
205 (abort-recursive-edit))))
|
|
|
206
|
|
|
207 (defun sc-log-exit ()
|
|
|
208 "Proceed with checkin with the contents of the current buffer as message."
|
|
|
209 (interactive)
|
|
|
210 (if (< (buffer-size) sc-max-log-size)
|
|
|
211 (progn
|
|
|
212 (copy-to-buffer sc-generic-log-buf (point-min) (point-max))
|
|
|
213 (exit-recursive-edit)
|
|
|
214 (delete-window))
|
|
|
215 (goto-char sc-max-log-size)
|
|
|
216 (error
|
|
|
217 "Log must be less than %d characters. Point is now at char %d."
|
|
|
218 sc-max-log-size (point))))
|
|
|
219
|
|
|
220
|
|
|
221 ;;; Functions to look at the edit history
|
|
|
222 (defun sc-show-changes (arg)
|
|
|
223 "Compare the version being edited with the last checked-in revision.
|
|
|
224 With a prefix argument prompt for revision to compare with."
|
|
|
225 (interactive "P")
|
|
|
226 ;; check that the file is not modified
|
|
|
227 (if (and (buffer-modified-p)
|
|
|
228 (or
|
|
|
229 sc-mode-expert
|
|
|
230 (y-or-n-p (format "%s has been modified. Write it out? "
|
|
|
231 (buffer-name)))))
|
|
|
232 (save-buffer))
|
|
|
233 (let* ((revision (and arg (read-string "Revision to compare against: ")))
|
|
|
234 (file buffer-file-name)
|
|
|
235 (name (file-name-nondirectory file))
|
|
|
236 (old (sc-get-version-in-temp-file file revision))
|
|
|
237 (buffer (sc-temp-buffer))
|
|
|
238 status)
|
|
|
239 (save-excursion
|
|
|
240 (set-buffer buffer)
|
|
|
241 (erase-buffer)
|
|
|
242 (setq default-directory (file-name-directory file))
|
|
|
243 (setq status
|
|
|
244 (apply 'call-process (car sc-diff-command) () t ()
|
|
|
245 (append (cdr sc-diff-command) (list old) (list file)))))
|
|
|
246 (if (not (or (eq 0 status) (eq 1 status))) ; see man diff.1
|
|
|
247 (progn
|
|
|
248 (display-buffer buffer)
|
|
|
249 (error "diff FAILED")))
|
|
|
250 (delete-file old)
|
|
|
251 (save-excursion
|
|
|
252 (set-buffer buffer)
|
|
|
253 (goto-char (point-min))
|
|
|
254 (if (equal (point-min) (point-max))
|
|
|
255 (insert
|
|
|
256 (format "No changes to %s since last update."
|
|
|
257 (file-name-nondirectory file)))
|
|
|
258 (insert "==== Diffs for " file "\n")
|
|
|
259 (insert "==== ")
|
|
|
260 (mapcar '(lambda (i) (insert i " ")) sc-diff-command)
|
|
|
261 (insert name "<" (or revision "current") ">" " " name "\n\n")))
|
|
|
262 (display-buffer buffer)))
|
|
|
263
|
|
|
264 (defun sc-show-revision-changes ()
|
|
|
265 "Prompt for a revision to diff against."
|
|
|
266 (interactive)
|
|
|
267 (sc-show-changes 4))
|
|
|
268
|
|
|
269 (defun sc-version-diff-file (file rel1 rel2)
|
|
|
270 "For FILE, report diffs between two revisions REL1 and REL2 of it."
|
|
|
271 (interactive "fFile: \nsOlder version: \nsNewer version: ")
|
|
|
272 (if (string-equal rel1 "") (setq rel1 nil))
|
|
|
273 (if (string-equal rel2 "") (setq rel2 nil))
|
|
|
274 (let ((buffer (sc-temp-buffer)))
|
|
|
275 (set-buffer buffer)
|
|
|
276 (erase-buffer)
|
|
|
277 (let ((v1 (sc-get-version-in-temp-file file rel1))
|
|
|
278 (v2 (if rel2 (sc-get-version-in-temp-file file rel2) file)))
|
|
|
279 (and v1
|
|
|
280 v2
|
|
|
281 (unwind-protect
|
|
|
282 (apply 'call-process (car sc-diff-command) nil t t
|
|
|
283 (append (cdr sc-diff-command) (list v1) (list v2)))))
|
|
|
284 (condition-case () (delete-file v1) (error nil))
|
|
|
285 (if rel2
|
|
|
286 (condition-case () (delete-file v2) (error nil)))
|
|
|
287 (set-buffer-modified-p nil)
|
|
|
288 (goto-char (point-min))
|
|
|
289 (if (equal (point-min) (point-max))
|
|
|
290 (message
|
|
|
291 (format "No changes to %s between %s and %s." file rel1 rel2))
|
|
|
292 (display-buffer buffer)))))
|
|
|
293
|
|
|
294 (defun sc-show-history ()
|
|
|
295 "List the edit history of the current buffer."
|
|
|
296 (interactive)
|
|
|
297 (let ((file buffer-file-name))
|
|
|
298 (if (not file)
|
|
|
299 (error "There is no file associated with buffer %s" (buffer-name)))
|
|
|
300 (if (not (sc-lock-info file))
|
|
|
301 (error "The file is not registered in the source control system"))
|
|
|
302 (let ((buffer (sc-temp-buffer)))
|
|
|
303 (save-excursion
|
|
|
304 (set-buffer buffer)
|
|
|
305 (erase-buffer)
|
|
|
306 (sc-history file)
|
|
|
307 (goto-char (point-min)))
|
|
|
308 (display-buffer buffer))))
|
|
|
309
|
|
|
310 (defun sc-visit-previous-revision (revision)
|
|
|
311 "Show a previous revision of the current file"
|
|
|
312 (interactive "sShow previous revision number: ")
|
|
|
313 (let ((file buffer-file-name))
|
|
|
314 (if (not file)
|
|
|
315 (error "There is no file associated with buffer %s" (buffer-name)))
|
|
|
316 (let ((other-file (sc-get-version-in-temp-file file revision))
|
|
|
317 (buffer-name (concat (file-name-nondirectory file)
|
|
|
318 "<" sc-generic-name " " revision ">")))
|
|
|
319 (pop-to-buffer (get-buffer-create buffer-name))
|
|
|
320 (erase-buffer)
|
|
|
321 (insert-file other-file)
|
|
|
322 ;; get the same major mode as the original file
|
|
|
323 (setq buffer-file-name file)
|
|
|
324 (normal-mode)
|
|
|
325 (setq buffer-file-name ())
|
|
|
326 (set-buffer-modified-p ())
|
|
|
327 (toggle-read-only)
|
|
|
328 (delete-file other-file))))
|
|
|
329
|
|
|
330 (defun sc-revert-file ()
|
|
|
331 "Revert the current buffer's file back to the last saved version."
|
|
|
332 (interactive)
|
|
|
333 (let ((file buffer-file-name))
|
|
|
334 (if (y-or-n-p (format "Revert file %s to last checked-in revision?" file))
|
|
|
335 (progn
|
|
|
336 (sc-revert file)
|
|
|
337 (revert-buffer nil t)
|
|
|
338 (sc-mode-line)))))
|
|
|
339
|
|
|
340 ;; Functions to get directory level information
|
|
|
341
|
|
|
342 (defun sc-list-all-locked-files (arg)
|
|
|
343 "List all files currently locked under the revision control system.
|
|
|
344 With prefix arg list only the files locked by the user."
|
|
|
345 (interactive "P")
|
|
|
346 (let* ((locker (and arg (user-login-name)))
|
|
|
347 (buffer (sc-tree-walk 'sc-list-file-if-locked locker)))
|
|
|
348 (save-excursion
|
|
|
349 (set-buffer buffer)
|
|
|
350 (goto-char (point-min))
|
|
|
351 (if (= (point-min) (point-max))
|
|
|
352 (insert "No files locked ")
|
|
|
353 (insert "Files locked "))
|
|
|
354 (if locker
|
|
|
355 (insert "by " locker " "))
|
|
|
356 (insert "in " default-directory "\n\n"))
|
|
|
357 (display-buffer buffer)))
|
|
|
358
|
|
|
359 (defun sc-list-locked-files ()
|
|
|
360 "List all files currently locked by me"
|
|
|
361 (interactive)
|
|
|
362 (sc-list-all-locked-files 4))
|
|
|
363
|
|
|
364 (defun sc-list-registered-files ()
|
|
|
365 "List all files currently registered under the revision control system."
|
|
|
366 (interactive)
|
|
|
367 (let ((buffer (sc-tree-walk 'sc-list-file)))
|
|
|
368 (save-excursion
|
|
|
369 (set-buffer buffer)
|
|
|
370 (if (= (point-min) (point-max))
|
|
|
371 (insert "No files registered in " sc-generic-name
|
|
|
372 " in " default-directory)
|
|
|
373 (goto-char (point-min))
|
|
|
374 (insert "Files registered in " sc-generic-name " in " default-directory
|
|
|
375 "\n\n")))
|
|
|
376 (display-buffer buffer)))
|
|
|
377
|
|
|
378 (defun sc-update-directory ()
|
|
|
379 "Updates the current directory by getting the latest copies of the files"
|
|
|
380 (interactive)
|
|
|
381 (save-some-buffers)
|
|
|
382 (let ((buffer (sc-tree-walk 'sc-update-file)))
|
|
|
383 (save-excursion
|
|
|
384 (set-buffer buffer)
|
|
|
385 (goto-char (point-min))
|
|
|
386 (if (= (point-min) (point-max))
|
|
|
387 (insert "No files needed to be updated in " default-directory "\n\n")
|
|
|
388 (insert "Files updated in " default-directory "\n\n")))
|
|
|
389 (display-buffer buffer)))
|
|
|
390
|
|
|
391 ;; Miscellaneous other entry points
|
|
|
392
|
|
|
393 (defun sc-register-file (verbose)
|
|
|
394 "Register the file visited by the current buffer into source control.
|
|
|
395 Prefix argument register it under an explicit revision number."
|
|
|
396 (interactive "P")
|
|
|
397 (let ((file buffer-file-name))
|
|
|
398 (if (not file)
|
|
|
399 (error "There is no file associated with buffer %s" (buffer-name)))
|
|
|
400 (let ((lock-info (sc-lock-info file))
|
|
|
401 (revision ()))
|
|
|
402 (if lock-info
|
|
|
403 (error "This file is already registered into %s" sc-generic-name))
|
|
|
404 ;; propose to save the file if it's modified
|
|
|
405 (if (and (buffer-modified-p)
|
|
|
406 (or
|
|
|
407 sc-mode-expert
|
|
|
408 (y-or-n-p (format "%s has been modified. Write it out? "
|
|
|
409 (buffer-name)))))
|
|
|
410 (save-buffer))
|
|
|
411 ;; get the revision number
|
|
|
412 (if verbose
|
|
|
413 (setq revision (read-string "Initial Revision Number: ")))
|
|
|
414 (sc-register file revision)
|
|
|
415 (revert-buffer nil t)
|
|
|
416 (sc-mode-line))))
|
|
|
417
|
|
|
418 (defun sc-rename-file (old new)
|
|
|
419 "Rename a file, taking its source control archive with it."
|
|
|
420 (interactive "fOld name: \nFNew name: ")
|
|
|
421 (let ((owner (sc-locking-user old)))
|
|
|
422 (if (and owner (not (string-equal owner (user-login-name))))
|
|
|
423 (error "Sorry, %s has that file checked out" owner)))
|
|
|
424 (if sc-can-hack-dir
|
|
|
425 (rename-file old new t))
|
|
|
426 (sc-rename old new))
|
|
|
427
|
|
|
428 (defun sc-rename-this-file (new)
|
|
|
429 "Rename the file of the current buffer, taking its source control archive with it"
|
|
|
430 (interactive "FNew name: ")
|
|
|
431 (if (and (buffer-modified-p)
|
|
|
432 (y-or-n-p (format "%s has been modified. Write it out? "
|
|
|
433 (buffer-name))))
|
|
|
434 (save-buffer))
|
|
|
435 (sc-rename-file buffer-file-name new)
|
|
|
436 (let ((old-buffer (current-buffer))
|
|
|
437 (new-buffer (find-file-noselect new)))
|
|
|
438 (set-window-buffer (selected-window) new-buffer)
|
|
|
439 (pop-to-buffer (current-buffer))
|
|
|
440 (bury-buffer old-buffer)))
|
|
|
441
|
|
|
442
|
|
|
443 ;;; Mode independent functions
|
|
|
444 ;;; All those sc-... functions FUNCALL the corresponding sc-generic-... function.
|
|
|
445 ;;; The variables are set to functions that do the SCCS, RCS or CVS commands
|
|
|
446 ;;; depending on the mode chosen.
|
|
|
447
|
|
|
448 (defvar sc-generic-lock-info ()
|
|
|
449 "Function to implement sc-lock-info")
|
|
|
450
|
|
|
451 (defun sc-lock-info (file)
|
|
|
452 "Return a list of the current locker and current locked revision for FILE.
|
|
|
453 Returns NIL if FILE is not registered in the source control system.
|
|
|
454 Return (NIL NIL) if FILE is registered but not locked.
|
|
|
455 Return (locker revision) if file is locked."
|
|
|
456 (funcall sc-generic-lock-info file))
|
|
|
457
|
|
|
458
|
|
|
459 (defvar sc-generic-register ()
|
|
|
460 "Function to implement sc-register")
|
|
|
461
|
|
|
462 (defun sc-register (file revision)
|
|
|
463 "Register FILE under source control with initial revision REVISION."
|
|
|
464 (funcall sc-generic-register file revision))
|
|
|
465
|
|
|
466
|
|
|
467 (defvar sc-generic-check-out ()
|
|
|
468 "Function to implement sc-check-out")
|
|
|
469
|
|
|
470 (defun sc-check-out (file lockp)
|
|
|
471 "Checks out the latest version of FILE.
|
|
|
472 If LOCKP is not NIL, FILE is also locked."
|
|
|
473 (funcall sc-generic-check-out file lockp))
|
|
|
474
|
|
|
475
|
|
|
476 (defvar sc-generic-get-version ()
|
|
|
477 "Function to implement sc-get-version")
|
|
|
478
|
|
|
479 (defun sc-get-version (file buffer revision)
|
|
|
480 "Insert a previous revison of FILE in BUFFER.
|
|
|
481 REVISION is the revision number requested."
|
|
|
482 (funcall sc-generic-get-version file buffer revision))
|
|
|
483
|
|
|
484
|
|
|
485 (defvar sc-generic-check-in ()
|
|
|
486 "Function to implement sc-check-in")
|
|
|
487
|
|
|
488 (defun sc-check-in (file revision message)
|
|
|
489 "Check in FILE with revision REVISION.
|
|
|
490 MESSAGE is a string describing the changes."
|
|
|
491 (funcall sc-generic-check-in file revision message))
|
|
|
492
|
|
|
493
|
|
|
494 (defvar sc-generic-history ()
|
|
|
495 "Function to implement sc-history")
|
|
|
496
|
|
|
497 (defun sc-history (file)
|
|
|
498 "Insert the edit history of FILE in the current buffer."
|
|
|
499 (funcall sc-generic-history file))
|
|
|
500
|
|
|
501
|
|
|
502 (defvar sc-generic-tree-list ()
|
|
|
503 "Function to implement sc-tree-list")
|
|
|
504
|
|
|
505 (defun sc-tree-list ()
|
|
|
506 "List in the current buffer the files registered in the source control system"
|
|
|
507 (funcall sc-generic-tree-list))
|
|
|
508
|
|
|
509
|
|
|
510 (defvar sc-generic-new-revision-p ()
|
|
|
511 "Function to implement sc-new-revision-p")
|
|
|
512
|
|
|
513 (defun sc-new-revision-p (file)
|
|
|
514 "True if a new revision of FILE was checked in since we last got a copy of it"
|
|
|
515 (funcall sc-generic-new-revision-p file))
|
|
|
516
|
|
|
517
|
|
|
518 (defvar sc-generic-revert ()
|
|
|
519 "Function to implement sc-revert")
|
|
|
520
|
|
|
521 (defun sc-revert (file)
|
|
|
522 "Cancel a check out of FILE and get back the latest checked in version"
|
|
|
523 (funcall sc-generic-revert file))
|
|
|
524
|
|
|
525
|
|
|
526 (defvar sc-generic-rename ()
|
|
|
527 "Function to implement sc-rename")
|
|
|
528
|
|
|
529 (defun sc-rename (old new)
|
|
|
530 "Rename the source control archives for OLD to NEW"
|
|
|
531 (funcall sc-generic-rename old new))
|
|
|
532
|
|
|
533
|
|
|
534 (defvar sc-menu ()
|
|
|
535 "Menu to use")
|
|
|
536
|
|
|
537
|
|
|
538 ;;; Utilities functions
|
|
|
539 (defun sc-do-command (buffer message command file sc-file &rest flags)
|
|
|
540 "Execute a command, notifying the user and checking for errors."
|
|
|
541 (setq file (expand-file-name file))
|
|
|
542 (message (format "Running %s on %s..." message file))
|
|
|
543 (let ((status
|
|
|
544 (save-excursion
|
|
|
545 (set-buffer (get-buffer-create buffer))
|
|
|
546 (erase-buffer)
|
|
|
547 (setq flags (append flags (and file (list sc-file))))
|
|
|
548 (setq flags (delq () flags))
|
|
|
549 (let ((default-directory (file-name-directory (or file "./"))))
|
|
|
550 (eq (apply 'call-process command nil t nil flags) 0)))))
|
|
|
551 (if status
|
|
|
552 (message (format "Running %s...OK" message))
|
|
|
553 (save-excursion
|
|
|
554 (set-buffer buffer)
|
|
|
555 (goto-char (point-min))
|
|
|
556 (insert command)
|
|
|
557 (mapcar '(lambda (i) (insert " " i)) flags)
|
|
|
558 (insert "\n\n")
|
|
|
559 (goto-char (point-min)))
|
|
|
560 (display-buffer buffer)
|
|
|
561 (error (format "Running %s...FAILED" message)))))
|
|
|
562
|
|
|
563 (defun sc-enter-comment ()
|
|
|
564 "Enter a comment. Return it as a string."
|
|
|
565 (let ((buffer (sc-temp-buffer)))
|
|
|
566 (setq sc-generic-log-buf
|
|
|
567 (get-buffer-create (format "*%s-Log*" sc-generic-name)))
|
|
|
568 (save-window-excursion
|
|
|
569 ;; this excursion returns t if the new version was saved OK
|
|
|
570 (pop-to-buffer buffer)
|
|
|
571 (erase-buffer)
|
|
|
572 (set-buffer-modified-p nil)
|
|
|
573 (sc-log-entry-mode)
|
|
|
574 (message
|
|
|
575 "Enter log message. Type C-c C-c when done, C-c ? for help.")
|
|
|
576 (prog1
|
|
|
577 (and (not (error-occurred (recursive-edit)))
|
|
|
578 (let ((bs (buffer-string)))
|
|
|
579 (if (> (length bs) 0) bs)))
|
|
|
580 (setq buffer-file-name nil)
|
|
|
581 (bury-buffer buffer)))))
|
|
|
582
|
|
|
583 (defun sc-locking-user (file)
|
|
|
584 "Return the login name of the locker of FILE. Return nil if FILE is not locked"
|
|
|
585 (car (sc-lock-info file)))
|
|
|
586
|
|
|
587 (defun sc-locked-revision (file)
|
|
|
588 "Return the revision number currently locked for FILE, nil if FILE is not locked."
|
|
|
589 (car (cdr (sc-lock-info file))))
|
|
|
590
|
|
|
591 (defun sc-mode-line ()
|
|
|
592 "Set the mode line for the current buffer.
|
|
|
593 FILE is the file being visited."
|
|
|
594 (let* ((file buffer-file-name)
|
|
|
595 (lock-info (sc-lock-info file)))
|
|
|
596 ;; ensure that the global mode string is not NIL
|
|
|
597 (or global-mode-string (setq global-mode-string '("")))
|
|
|
598 ;; ensure that our variable is in the global-mode-string
|
|
|
599 (or (memq 'sc-mode-line-string global-mode-string)
|
|
|
600 (setq global-mode-string
|
|
|
601 (append global-mode-string '(sc-mode-line-string))))
|
|
|
602 (make-local-variable 'sc-mode-line-string)
|
|
|
603 (setq sc-mode-line-string
|
|
|
604 (cond ((or
|
|
|
605 (eq lock-info 'na)
|
|
|
606 (null lock-info)) ())
|
|
|
607 ((null (car lock-info))
|
|
|
608 (format " <%s:>" sc-generic-name))
|
|
|
609 ((equal (car lock-info) (user-login-name))
|
|
|
610 (format " <%s: %s>" sc-generic-name (car (cdr lock-info))))
|
|
|
611 (t
|
|
|
612 (format " <%s: %s>" sc-generic-name (car lock-info)))))))
|
|
|
613
|
|
|
614 (defun sc-temp-buffer ()
|
|
|
615 "Return a temporary buffer to use for output"
|
|
|
616 (get-buffer-create (format "*%s*" sc-generic-name)))
|
|
|
617
|
|
|
618 (defun sc-tree-walk (func &rest args)
|
|
|
619 "Apply FUNC to the files registered in the source control system.
|
|
|
620 FUNC is passed the file path and ARGS."
|
|
|
621 (let* ((buffer-name (format "*%s directory*" sc-generic-name))
|
|
|
622 (buffer (get-buffer-create buffer-name))
|
|
|
623 (dir default-directory)
|
|
|
624 files)
|
|
|
625 ;; recreate the directory buffer in the right directory
|
|
|
626 (save-excursion
|
|
|
627 (set-buffer buffer)
|
|
|
628 (erase-buffer)
|
|
|
629 (setq default-directory dir)
|
|
|
630 ;; get a list of all the registered files
|
|
|
631 (sc-tree-list)
|
|
|
632 ;; remove the "not found" messages
|
|
|
633 (goto-char (point-min))
|
|
|
634 (while (search-forward "not found" () t)
|
|
|
635 (beginning-of-line 1)
|
|
|
636 (kill-line 1))
|
|
|
637 ;; check if any file is listed
|
|
|
638 (if (= (point-min) (point-max))
|
|
|
639 (error "No registered files under %s" default-directory))
|
|
|
640 ;; build the list of files
|
|
|
641 (goto-char (point-min))
|
|
|
642 (setq files ())
|
|
|
643 (while (not (eobp))
|
|
|
644 (let ((file
|
|
|
645 (buffer-substring (point) (progn (end-of-line) (point)))))
|
|
|
646 (setq files (cons file files)))
|
|
|
647 (forward-line 1))
|
|
|
648 (setq files (nreverse files))
|
|
|
649 ;; let the function output information in the buffer
|
|
|
650 (erase-buffer))
|
|
|
651 (display-buffer buffer)
|
|
|
652 ;; apply the function
|
|
|
653 (save-excursion
|
|
|
654 (set-buffer buffer)
|
|
|
655 (while files
|
|
|
656 (apply func (car files) args)
|
|
|
657 (setq files (cdr files)))
|
|
|
658 buffer)))
|
|
|
659
|
|
|
660 (defun sc-get-version-in-temp-file (file revision)
|
|
|
661 "For the given FILE, retrieve a copy of the version with given REVISION.
|
|
|
662 The text is retrieved into a tempfile. Return the tempfile name."
|
|
|
663 (let* ((oldversion
|
|
|
664 (make-temp-name
|
|
|
665 (concat (or (ccase-protect-expanded-name revision) "current")
|
|
|
666 "-"
|
|
|
667 (file-name-nondirectory file)
|
|
|
668 "-")))
|
|
|
669 (vbuf (get-buffer-create oldversion)))
|
|
|
670 (sc-get-version file vbuf revision)
|
|
|
671 (save-excursion
|
|
|
672 (set-buffer vbuf)
|
|
|
673 (write-region (point-min) (point-max) oldversion t 0))
|
|
|
674 (kill-buffer vbuf)
|
|
|
675 (sc-chmod "-w" oldversion)
|
|
|
676 oldversion))
|
|
|
677
|
|
|
678 ;; Functions used to get directory level information
|
|
|
679
|
|
|
680 (defun sc-insert-file-lock-info (file lock-info)
|
|
|
681 (insert (car lock-info) ":" (car (cdr lock-info)))
|
|
|
682 (indent-to-column 16 1)
|
|
|
683 (insert (file-name-nondirectory file) "\n"))
|
|
|
684
|
|
|
685 (defun sc-list-file-if-locked (file &optional arg)
|
|
|
686 "List all files underneath the current directory matching a prefix type."
|
|
|
687 (let ((lock-info (sc-lock-info file)))
|
|
|
688 (if (and lock-info
|
|
|
689 (car lock-info)
|
|
|
690 (or (null arg) (equal arg (car lock-info))))
|
|
|
691 (progn
|
|
|
692 (sc-insert-file-lock-info file lock-info)
|
|
|
693 (sit-for 0)))))
|
|
|
694
|
|
|
695 (defun sc-list-file (file)
|
|
|
696 (let ((lock-info (sc-lock-info file)))
|
|
|
697 (cond ((eq lock-info 'na)
|
|
|
698 (indent-to-column 16 1)
|
|
|
699 (insert (file-name-nondirectory file) "\n"))
|
|
|
700 ((car lock-info)
|
|
|
701 (sc-insert-file-lock-info file lock-info))
|
|
|
702 ((sc-new-revision-p file)
|
|
|
703 (insert "needs update")
|
|
|
704 (indent-to-column 16 1)
|
|
|
705 (insert (file-name-nondirectory file) "\n"))
|
|
|
706 (t
|
|
|
707 (indent-to-column 16 1)
|
|
|
708 (insert (file-name-nondirectory file) "\n")))
|
|
|
709 (sit-for 0)))
|
|
|
710
|
|
|
711 ;;; Function to update one file from the archive
|
|
|
712 (defun sc-update-file (file)
|
|
|
713 "get the latest version of the file if a new one was checked-in"
|
|
|
714 (if (sc-new-revision-p file)
|
|
|
715 (let ((file-name (file-name-nondirectory file)))
|
|
|
716 ;; get the latest copy
|
|
|
717 (rename-file (sc-get-version-in-temp-file file nil) file t)
|
|
|
718 (let ((b (get-file-buffer file)))
|
|
|
719 (if b
|
|
|
720 (save-excursion
|
|
|
721 (set-buffer b)
|
|
|
722 (revert-buffer nil t)
|
|
|
723 (sc-mode-line))))
|
|
|
724 ;; show the file was updated
|
|
|
725 (insert "updated")
|
|
|
726 (indent-to-column 16 1)
|
|
|
727 (insert file-name "\n")
|
|
|
728 (sit-for 0))))
|
|
|
729
|
|
|
730 ;; Set up key bindings for use while editing log messages
|
|
|
731
|
|
|
732 (if sc-log-entry-keymap
|
|
|
733 nil
|
|
|
734 (setq sc-log-entry-keymap (make-sparse-keymap))
|
|
|
735 (define-key sc-log-entry-keymap "\C-ci" 'sc-insert-last-log)
|
|
|
736 (define-key sc-log-entry-keymap "\C-c\C-i" 'sc-insert-last-log)
|
|
|
737 (define-key sc-log-entry-keymap "\C-ca" 'sc-abort-check-in)
|
|
|
738 (define-key sc-log-entry-keymap "\C-c\C-a" 'sc-abort-check-in)
|
|
|
739 (define-key sc-log-entry-keymap "\C-c\C-c" 'sc-log-exit)
|
|
|
740 (define-key sc-log-entry-keymap "\C-x\C-s" 'sc-log-exit))
|
|
|
741
|
|
|
742 (defvar sc-mode-hook nil
|
|
|
743 "*Function or functions to run on entry to sc-mode.")
|
|
|
744
|
|
|
745 (defvar sc-mode ()
|
|
|
746 "The currently active source control mode. Use M-x sc-mode to set it")
|
|
|
747
|
|
|
748 ;;;###autoload
|
|
|
749 (defun sc-mode (system)
|
|
|
750 "Toggle sc-mode.
|
|
|
751 SYSTEM can be sccs, rcs or cvs.
|
|
|
752 Cvs requires the pcl-cvs package.
|
|
|
753
|
|
|
754 The following commands are available
|
|
|
755 \\[sc-next-operation] perform next logical source control operation on current file
|
|
|
756 \\[sc-show-changes] compare the version being edited with an older one
|
|
|
757 \\[sc-version-diff-file] compare two older versions of a file
|
|
|
758 \\[sc-show-history] display change history of current file
|
|
|
759 \\[sc-visit-previous-revision] display an older revision of current file
|
|
|
760 \\[sc-revert-file] revert buffer to last checked-in version
|
|
|
761 \\[sc-list-all-locked-files] show all files locked in current directory
|
|
|
762 \\[sc-list-locked-files] show all files locked by you in current directory
|
|
|
763 \\[sc-list-registered-files] show all files under source control in current directory
|
|
|
764 \\[sc-update-directory] get fresh copies of files checked-in by others in current directory
|
|
|
765 \\[sc-rename-file] rename the current file and its source control file
|
|
|
766
|
|
|
767
|
|
|
768 While you are entering a change log message for a check in, sc-log-entry-mode
|
|
|
769 will be in effect.
|
|
|
770
|
|
|
771 Global user options:
|
|
|
772 sc-diff-command A list consisting of the command and flags
|
|
|
773 to be used for generating context diffs.
|
|
|
774 sc-mode-expert suppresses some conformation prompts,
|
|
|
775 notably for delta aborts and file saves.
|
|
|
776 sc-max-log-size specifies the maximum allowable size
|
|
|
777 of a log message plus one.
|
|
|
778
|
|
|
779
|
|
|
780 When using SCCS you have additional commands and options
|
|
|
781
|
|
|
782 \\[sccs-insert-headers] insert source control headers in current file
|
|
|
783
|
|
|
784 When you generate headers into a buffer using \\[sccs-insert-headers],
|
|
|
785 the value of sc-insert-headers-hook is called before insertion. If the
|
|
|
786 file is recognized a C or Lisp source, sc-insert-c-header-hook or
|
|
|
787 sc-insert-lisp-header-hook is called after insertion respectively.
|
|
|
788
|
|
|
789 sccs-headers-wanted which %-keywords to insert when adding
|
|
|
790 headers with C-c h
|
|
|
791 sccs-insert-static if non-nil, keywords inserted in C files
|
|
|
792 get stuffed in a static string area so that
|
|
|
793 what(1) can see them in the compiled object code.
|
|
|
794
|
|
|
795 When using CVS you have additional commands
|
|
|
796
|
|
|
797 \\[sc-cvs-update-directory] update the current directory using pcl-cvs
|
|
|
798 \\[sc-cvs-file-status] show the CVS status of current file
|
|
|
799 "
|
|
|
800 (interactive
|
|
|
801 (if sc-mode
|
|
|
802 '(())
|
|
|
803 (list
|
|
|
804 (intern
|
|
|
805 (read-string "Turn on source control mode on for: " "SCCS")))))
|
|
|
806 (cond ((eq system ())
|
|
|
807 (remove-hook 'find-file-hooks 'sc-mode-line)
|
|
|
808 (delete-menu-item (list sc-generic-name))
|
|
|
809 (remove-hook 'activate-menubar-hook 'sc-sensitize-menu)
|
|
|
810 (setq sc-mode ()))
|
|
|
811 (sc-mode
|
|
|
812 (sc-mode ())
|
|
|
813 (sc-mode system))
|
|
|
814 (t
|
|
|
815 (setq system (intern (upcase (symbol-name system))))
|
|
|
816 (let ((f (intern (format "sc-set-%s-mode" system))))
|
|
|
817 (if (not (fboundp f))
|
|
|
818 (error
|
|
|
819 "No source control interface for \"%s\". \
|
|
|
820 Please use SCCS, RCS, CVS, or Atria."
|
|
|
821 system)
|
|
|
822 (funcall f)
|
|
|
823 (add-hook 'find-file-hooks 'sc-mode-line)
|
|
2
|
824 (add-submenu '() (cons sc-generic-name sc-menu))
|
|
0
|
825 (add-hook 'activate-menubar-hook 'sc-sensitize-menu)
|
|
|
826 (run-hooks 'sc-mode-hook)
|
|
|
827 (setq sc-mode system))))))
|
|
|
828
|
|
|
829 (defun sc-log-entry-mode ()
|
|
|
830 "Major mode for editing log message.
|
|
|
831
|
|
|
832 These bindings are available when entering the log message
|
|
|
833 \\[sc-log-exit] proceed with check in, ending log message entry
|
|
|
834 \\[sc-insert-last-log] insert log message from last check-in
|
|
|
835 \\[sc-abort-check-in] abort this check-in
|
|
|
836
|
|
|
837 Entry to the change-log submode calls the value of text-mode-hook, then
|
|
|
838 the value sc-log-entry-mode-hook.
|
|
|
839 "
|
|
|
840 (interactive)
|
|
|
841 (set-syntax-table text-mode-syntax-table)
|
|
|
842 (use-local-map sc-log-entry-keymap)
|
|
|
843 (setq local-abbrev-table text-mode-abbrev-table)
|
|
|
844 (setq major-mode 'sc-log-entry-mode)
|
|
|
845 (setq mode-name "Source Control Change Log Entry")
|
|
|
846 (run-hooks 'text-mode-hook 'sc-log-entry-mode-hook))
|
|
|
847
|
|
|
848
|
|
|
849
|
|
|
850 ;;; SCCS specific part
|
|
|
851
|
|
|
852 ;; Find a reasonable default for the SCCS bin directory
|
|
|
853 (defvar sccs-bin-directory
|
|
|
854 (cond ((file-executable-p "/usr/sccs/unget") "/usr/sccs")
|
|
|
855 ((file-executable-p "/usr/bin/unget") "/usr/bin")
|
|
|
856 ((file-directory-p "/usr/sccs") "/usr/sccs")
|
|
|
857 ((file-directory-p "/usr/bin/sccs") "/usr/bin/sccs")
|
|
|
858 (t "/usr/bin"))
|
|
|
859 "*Directory where to find the sccs executables")
|
|
|
860
|
|
|
861 (defvar sccs-headers-wanted '("\%\W\%")
|
|
|
862 "*SCCS header keywords to be inserted when sccs-insert-header is executed.")
|
|
|
863
|
|
|
864 (defvar sccs-insert-static t
|
|
|
865 "*Insert a static character string when inserting source control headers in C mode.
|
|
|
866 Only relevant for the SCCS mode.")
|
|
|
867
|
|
|
868 ;; Vars the user doesn't need to know about.
|
|
|
869
|
|
|
870 (defvar sccs-log-entry-mode nil)
|
|
|
871 (defvar sccs-current-major-version nil)
|
|
|
872
|
|
|
873 ;; Some helper functions
|
|
|
874
|
|
|
875 (defun sccs-name (file &optional letter)
|
|
|
876 "Return the sccs-file name corresponding to a given file."
|
|
|
877 (if (null file)
|
|
|
878 ()
|
|
|
879 (let ((expanded-file (expand-file-name file)))
|
|
|
880 (format "%sSCCS/%s.%s"
|
|
|
881 (concat (file-name-directory expanded-file))
|
|
|
882 (or letter "s")
|
|
|
883 (concat (file-name-nondirectory expanded-file))))))
|
|
|
884
|
|
|
885 (defun sccs-lock-info (file)
|
|
|
886 "Lock-info method for SCCS. See sc-generic-lock-info"
|
|
|
887 (let ((sccs-file (sccs-name file "s"))
|
|
|
888 (lock-file (sccs-name file "p")))
|
|
|
889 (cond ((or (null file) (not (file-exists-p sccs-file)))
|
|
|
890 ())
|
|
|
891 ((not (file-exists-p lock-file))
|
|
|
892 (list () ()))
|
|
|
893 (t
|
|
|
894 (save-excursion
|
|
|
895 (set-buffer (get-buffer-create "*SCCS tmp*"))
|
|
|
896 (insert-file lock-file)
|
|
|
897 (while (search-forward " " () t)
|
|
|
898 (replace-match "\n" () t))
|
|
|
899 (goto-char (point-min))
|
|
|
900 (forward-line 1)
|
|
|
901 (let ((revision
|
|
|
902 (buffer-substring (point) (progn (end-of-line) (point))))
|
|
|
903 (name
|
|
|
904 (progn (forward-line 1)
|
|
|
905 (buffer-substring (point)
|
|
|
906 (progn (end-of-line) (point))))))
|
|
|
907 (kill-buffer (current-buffer))
|
|
|
908 (list name revision)))))))
|
|
|
909
|
|
|
910
|
|
|
911 (defun sccs-do-command (buffer command file &rest flags)
|
|
|
912 "Execute an SCCS command, notifying the user and checking for errors."
|
|
|
913 (let ((exec-path (cons sccs-bin-directory exec-path)))
|
|
|
914 (apply 'sc-do-command buffer command command file (sccs-name file) flags)))
|
|
|
915
|
|
|
916 (defun sccs-admin (file sid)
|
|
|
917 "Checks a file into sccs.
|
|
|
918 FILE is the unmodified name of the file. SID should be the base-level sid to
|
|
|
919 check it in under."
|
|
|
920 ;; give a change to save the file if it's modified
|
|
|
921 (if (and (buffer-modified-p)
|
|
|
922 (y-or-n-p (format "%s has been modified. Write it out? "
|
|
|
923 (buffer-name))))
|
|
|
924 (save-buffer))
|
|
|
925 (sccs-do-command "*SCCS*" "admin" file
|
|
|
926 (concat "-i" file) (concat "-r" sid))
|
|
|
927 (sc-chmod "-w" file)
|
|
|
928 ;; expand SCCS headers
|
|
|
929 (sccs-check-out file nil))
|
|
|
930
|
|
|
931 (defun sccs-register (file revision)
|
|
|
932 (sccs-load-vars)
|
|
|
933 (if (and (not (file-exists-p "SCCS"))
|
|
|
934 (y-or-n-p "Directory SCCS does not exist, create it?"))
|
|
|
935 (make-directory "SCCS"))
|
|
|
936 (sccs-admin file
|
|
|
937 (cond
|
|
|
938 (revision revision)
|
|
|
939 ((error-occurred (load-file "SCCS/emacs-vars.el")) "1")
|
|
|
940 (t sccs-current-major-version))))
|
|
|
941
|
|
|
942 (defun sccs-check-out (file lockp)
|
|
|
943 "Retrieve a copy of the latest version of the given file."
|
|
|
944 (sccs-do-command "*SCCS*" "get" file (if lockp "-e")))
|
|
|
945
|
|
|
946 (defun sccs-get-version (file buffer revision)
|
|
|
947 (sccs-do-command buffer "get" file
|
|
|
948 (and revision (concat "-r" revision))
|
|
|
949 "-p" "-s"))
|
|
|
950
|
|
|
951 (defun sccs-check-in (file revision comment)
|
|
|
952 "Check-in a given version of the given file with the given comment."
|
|
|
953 (sccs-do-command "*SCCS*" "delta" file "-n"
|
|
|
954 (format "-r%s" revision)
|
|
|
955 (format "-y%s" comment))
|
|
|
956 (sc-chmod "-w" file)
|
|
|
957 ;; sccs-delta already turned off write-privileges on the
|
|
|
958 ;; file, let's not re-fetch it unless there's something
|
|
|
959 ;; in it that get would expand
|
|
|
960 (save-excursion
|
|
|
961 (let ((buffer (get-file-buffer file)))
|
|
|
962 (if buffer
|
|
|
963 (progn
|
|
|
964 (set-buffer buffer)
|
|
|
965 (sccs-check-out file nil))))))
|
|
|
966
|
|
|
967 (defun sccs-history (file)
|
|
|
968 (sccs-do-command (current-buffer) "prs" file))
|
|
|
969
|
|
|
970 ;; There has *got* to be a better way to do this...
|
|
|
971
|
|
|
972 (defun sccs-save-vars (sid)
|
|
|
973 (save-excursion
|
|
|
974 (find-file "SCCS/emacs-vars.el")
|
|
|
975 (erase-buffer)
|
|
|
976 (insert "(setq sccs-current-major-version \"" sid "\")")
|
|
|
977 (basic-save-buffer)))
|
|
|
978
|
|
|
979 (defun sccs-load-vars ()
|
|
|
980 (if (error-occurred (load-file "SCCS/emacs-vars.el"))
|
|
|
981 (setq sccs-current-major-version "1")))
|
|
|
982
|
|
|
983 ;; SCCS header insertion code
|
|
|
984
|
|
|
985 (defun sccs-insert-headers ()
|
|
|
986 "*Insert headers for use with the Source Code Control System.
|
|
|
987 Headers desired are inserted at the start of the buffer, and are pulled from
|
|
|
988 the variable sccs-headers-wanted"
|
|
|
989 (interactive)
|
|
|
990 (save-excursion
|
|
|
991 (save-restriction
|
|
|
992 (widen)
|
|
|
993 (if (or (not (sccs-check-headers))
|
|
|
994 (y-or-n-p "SCCS headers already exist. Insert another set?"))
|
|
|
995 (progn
|
|
|
996 (goto-char (point-min))
|
|
|
997 (run-hooks 'sccs-insert-headers-hook)
|
|
|
998 (cond ((eq major-mode 'c-mode) (sccs-insert-c-header))
|
|
|
999 ((eq major-mode 'lisp-mode) (sccs-insert-lisp-header))
|
|
|
1000 ((eq major-mode 'emacs-lisp-mode) (sccs-insert-lisp-header))
|
|
|
1001 ((eq major-mode 'scheme-mode) (sccs-insert-lisp-header))
|
|
|
1002 ((eq major-mode 'nroff-mode) (sccs-insert-nroff-header))
|
|
|
1003 ((eq major-mode 'plain-tex-mode) (sccs-insert-tex-header))
|
|
|
1004 ((eq major-mode 'texinfo-mode) (sccs-insert-texinfo-header))
|
|
|
1005 (t (sccs-insert-generic-header))))))))
|
|
|
1006
|
|
|
1007
|
|
|
1008
|
|
|
1009 (defun sccs-insert-c-header ()
|
|
|
1010 (let (st en)
|
|
|
1011 (insert "/*\n")
|
|
|
1012 (mapcar '(lambda (s)
|
|
|
1013 (insert " *\t" s "\n"))
|
|
|
1014 sccs-headers-wanted)
|
|
|
1015 (insert " */\n\n")
|
|
|
1016 (if (and sccs-insert-static
|
|
|
1017 (not (string-match "\\.h$" buffer-file-name)))
|
|
|
1018 (progn
|
|
|
1019 (insert "#ifndef lint\n"
|
|
|
1020 "static char *sccsid")
|
|
|
1021 ;; (setq st (point))
|
|
|
1022 ;; (insert (file-name-nondirectory buffer-file-name))
|
|
|
1023 ;; (setq en (point))
|
|
|
1024 ;; (subst-char-in-region st en ?. ?_)
|
|
|
1025 (insert " = \"\%\W\%\";\n"
|
|
|
1026 "#endif /* lint */\n\n")))
|
|
|
1027 (run-hooks 'sccs-insert-c-header-hook)))
|
|
|
1028
|
|
|
1029 (defun sccs-insert-lisp-header ()
|
|
|
1030 (mapcar '(lambda (s)
|
|
|
1031 (insert ";;;\t" s "\n"))
|
|
|
1032 sccs-headers-wanted)
|
|
|
1033 (insert "\n")
|
|
|
1034 (run-hooks 'sccs-insert-lisp-header-hook))
|
|
|
1035
|
|
|
1036 (defun sccs-insert-nroff-header ()
|
|
|
1037 (mapcar '(lambda (s)
|
|
|
1038 (insert ".\\\"\t" s "\n"))
|
|
|
1039 sccs-headers-wanted)
|
|
|
1040 (insert "\n")
|
|
|
1041 (run-hooks 'sccs-insert-nroff-header-hook))
|
|
|
1042
|
|
|
1043 (defun sccs-insert-tex-header ()
|
|
|
1044 (mapcar '(lambda (s)
|
|
|
1045 (insert "%%\t" s "\n"))
|
|
|
1046 sccs-headers-wanted)
|
|
|
1047 (insert "\n")
|
|
|
1048 (run-hooks 'sccs-insert-tex-header-hook))
|
|
|
1049
|
|
|
1050 (defun sccs-insert-texinfo-header ()
|
|
|
1051 (mapcar '(lambda (s)
|
|
|
1052 (insert "@comment\t" s "\n"))
|
|
|
1053 sccs-headers-wanted)
|
|
|
1054 (insert "\n")
|
|
|
1055 (run-hooks 'sccs-insert-texinfo-header-hook))
|
|
|
1056
|
|
|
1057 (defun sccs-insert-generic-header ()
|
|
|
1058 (let* ((comment-start-sccs (or comment-start "#"))
|
|
|
1059 (comment-end-sccs (or comment-end ""))
|
|
|
1060 (dont-insert-nl-p (string-match "\n" comment-end-sccs)))
|
|
|
1061 (mapcar '(lambda (s)
|
|
|
1062 (insert comment-start-sccs "\t" s ""
|
|
|
1063 comment-end-sccs (if dont-insert-nl-p "" "\n")))
|
|
|
1064 sccs-headers-wanted)
|
|
|
1065 (insert comment-start-sccs comment-end-sccs (if dont-insert-nl-p "" "\n"))))
|
|
|
1066
|
|
|
1067 (defun sccs-check-headers ()
|
|
|
1068 "Check if the current file has any SCCS headers in it."
|
|
|
1069 (save-excursion
|
|
|
1070 (goto-char (point-min))
|
|
|
1071 (let ((case-fold-search ()))
|
|
|
1072 (re-search-forward "%[MIRLBSDHTEGUYFPQCZWA]%" (point-max) t))))
|
|
|
1073
|
|
|
1074 (defun sccs-tree-list ()
|
|
|
1075 "List all the registered files in the current directory"
|
|
|
1076 (call-process "/bin/sh" () t () "-c"
|
|
|
1077 (concat "/bin/ls -1 " default-directory "SCCS/s.*"))
|
|
|
1078 (goto-char (point-min))
|
|
|
1079 (while (search-forward "SCCS/s." () t)
|
|
|
1080 (replace-match "" () t)))
|
|
|
1081
|
|
|
1082 (defun sccs-new-revision-p (file)
|
|
|
1083 "True if the SCCS archive is more recent than the file itself"
|
|
|
1084 (file-newer-than-file-p (sccs-name file) file))
|
|
|
1085
|
|
|
1086 (defun sccs-revert (file)
|
|
|
1087 "Cancel a check-out and get a fresh copy of the file"
|
|
|
1088 (delete-file (sccs-name file "p"))
|
|
|
1089 (delete-file file)
|
|
|
1090 (sccs-do-command "*SCCS*" "get" file "-s"))
|
|
|
1091
|
|
|
1092 (defun sccs-rename (old new)
|
|
|
1093 "Rename the SCCS archives for OLD to NEW"
|
|
|
1094 (if (file-exists-p (sccs-name old "p"))
|
|
|
1095 (rename-file (sccs-name old "p") (sccs-name new "p") t))
|
|
|
1096 (if (file-exists-p (sccs-name old "s"))
|
|
|
1097 (rename-file (sccs-name old "s") (sccs-name new "s") t)))
|
|
|
1098
|
|
|
1099
|
|
|
1100 ;;; RCS specific part
|
|
|
1101
|
|
|
1102 ;; Some helper functions
|
|
|
1103
|
|
|
1104 (defun rcs-name (file)
|
|
|
1105 "Return the rcs-file corresponding to a given file."
|
|
|
1106 (if (null file)
|
|
|
1107 ()
|
|
|
1108 (let* ((name (expand-file-name file))
|
|
|
1109 (rcs-file (concat name ",v")))
|
|
|
1110 (if (and (not (file-exists-p rcs-file))
|
|
|
1111 (file-exists-p (concat (file-name-directory name) "RCS")))
|
|
|
1112 (setq rcs-file
|
|
|
1113 (format "%sRCS/%s,v" (file-name-directory name)
|
|
|
1114 (file-name-nondirectory name))))
|
|
|
1115 rcs-file)))
|
|
|
1116
|
|
|
1117 (defun rcs-lock-info (file)
|
|
|
1118 "Lock-info method for RCS. See sc-generic-lock-info"
|
|
|
1119 (let ((rcs-file (rcs-name file))
|
|
|
1120 locks-regexp)
|
|
|
1121 (if (or (null rcs-file) (not (file-exists-p rcs-file)))
|
|
|
1122 ()
|
|
|
1123 (save-excursion
|
|
|
1124 (set-buffer (get-buffer-create "*RCS tmp*"))
|
|
|
1125 (erase-buffer)
|
|
|
1126 (call-process "rlog" () t () "-L" "-h" rcs-file)
|
|
|
1127 (goto-char (point-min))
|
|
|
1128 (if (looking-at "\n.*Working file")
|
|
|
1129 ;; RCS 4.x
|
|
|
1130 (setq locks-regexp "^locks:")
|
|
|
1131 ;; RCS 5.x
|
|
|
1132 (setq locks-regexp "^locks:.*$\n"))
|
|
|
1133 (if (not (re-search-forward locks-regexp () t))
|
|
|
1134 (list () ())
|
|
|
1135 (if (not (looking-at (concat "[\t ]*\\([^:]*\\): \\([0-9\\.]*\\)")))
|
|
|
1136 (list () ())
|
|
|
1137 (list (buffer-substring (match-beginning 1) (match-end 1))
|
|
|
1138 (buffer-substring (match-beginning 2) (match-end 2)))))))))
|
|
|
1139
|
|
|
1140
|
|
|
1141 (defun rcs-register (file revision)
|
|
|
1142 (if (and (not (file-exists-p "RCS"))
|
|
|
1143 (y-or-n-p "Directory RCS does not exist, create it?"))
|
|
2
|
1144 (make-directory "RCS"))
|
|
0
|
1145 (sc-do-command "*RCS*" "ci" "ci" file (rcs-name file) "-u"))
|
|
|
1146
|
|
|
1147 (defun rcs-check-out (file lockp)
|
|
|
1148 (sc-do-command "*RCS*" "co" "co" file (rcs-name file) (if lockp "-l")))
|
|
|
1149
|
|
|
1150 (defun rcs-get-version (file buffer revision)
|
|
|
1151 (sc-do-command buffer "co" "co" file (rcs-name file)
|
|
|
1152 (if revision (concat "-p" revision) "-p")
|
|
|
1153 "-q"))
|
|
|
1154
|
|
|
1155 (defun rcs-check-in (file revision comment)
|
|
|
1156 "Check-in a given version of the given file with the given comment."
|
|
|
1157 (sc-do-command "*RCS*" "ci" "ci" file (rcs-name file) "-f"
|
|
|
1158 (format "-m%s" comment)
|
|
|
1159 (if (equal revision (sc-locked-revision file))
|
|
|
1160 "-u"
|
|
|
1161 (format "-u%s" revision))))
|
|
|
1162
|
|
|
1163 (defun rcs-history (file)
|
|
|
1164 (sc-do-command (current-buffer) "rlog" "rlog" file (rcs-name file)))
|
|
|
1165
|
|
|
1166 (defun rcs-tree-list ()
|
|
|
1167 "List all the registered files in the current directory"
|
|
|
1168 (call-process "/bin/sh" () t () "-c"
|
|
|
1169 (concat "/bin/ls -1 " default-directory "RCS/*,v"))
|
|
|
1170 (call-process "/bin/sh" () t () "-c"
|
|
|
1171 (concat "/bin/ls -1 " default-directory "*,v"))
|
|
|
1172 (goto-char (point-min))
|
|
|
1173 (while (search-forward "RCS/" () t)
|
|
|
1174 (replace-match "" () t))
|
|
|
1175 (goto-char (point-min))
|
|
|
1176 (while (search-forward ",v" () t)
|
|
|
1177 (replace-match "" () t)))
|
|
|
1178
|
|
|
1179 (defun rcs-new-revision-p (file)
|
|
|
1180 "True if the archive is more recent than the file itself"
|
|
|
1181 (file-newer-than-file-p (rcs-name file) file))
|
|
|
1182
|
|
|
1183 (defun rcs-revert (file)
|
|
|
1184 "Cancel a check-out and get a fresh copy of the file"
|
|
|
1185 (sc-do-command "*RCS*" "rcs" "rcs" file (rcs-name file) "-u")
|
|
|
1186 (delete-file file)
|
|
|
1187 (sc-do-command "*RCS*" "co" "co" file (rcs-name file)))
|
|
|
1188
|
|
|
1189 (defun rcs-rename (old new)
|
|
|
1190 "Rename the archives for OLD to NEW"
|
|
|
1191 (if (file-exists-p (rcs-name old))
|
|
|
1192 (rename-file (rcs-name old) (rcs-name new) t)))
|
|
|
1193
|
|
|
1194
|
|
|
1195 ;;; CVS specific part
|
|
|
1196
|
|
|
1197 ;;; As we rely on pcl-cvs for the directory level functions the menu is
|
|
|
1198 ;;; much shorter in CVS mode
|
|
|
1199
|
|
|
1200
|
|
|
1201 (defun cvs-lock-info (file)
|
|
|
1202 "Lock-info method for CVS, different from RCS and SCCS modes.
|
|
|
1203 File are never locked in CVS."
|
|
|
1204 (list () ()))
|
|
|
1205
|
|
|
1206 (defun cvs-register (file revision)
|
|
|
1207 (sc-do-command "*CVS*" "cvs add" cvs-program file
|
|
|
1208 (file-name-nondirectory file)
|
|
|
1209 "add" "-mInitial revision"))
|
|
|
1210
|
|
|
1211 (defun cvs-check-out (file lockp)
|
|
|
1212 )
|
|
|
1213
|
|
|
1214 (defun cvs-get-version (file buffer revision)
|
|
|
1215 (sc-do-command buffer "cvs update" cvs-program file file "update"
|
|
|
1216 (if revision (concat "-r" revision))
|
|
|
1217 "-p" "-q"))
|
|
|
1218
|
|
|
1219 (defun cvs-check-in (file revision comment)
|
|
|
1220 "Check-in a given version of the given file with the given comment."
|
|
|
1221 (sc-do-command "*CVS*" "cvs commit" cvs-program file file "commit"
|
|
|
1222 (and revision (format "-r%s" revision))
|
|
|
1223 (format "-m%s" comment)))
|
|
|
1224
|
|
|
1225 (defun cvs-history (file)
|
|
|
1226 (sc-do-command (current-buffer) "cvs log" cvs-program file file "log"))
|
|
|
1227
|
|
|
1228 (defun cvs-revert (file)
|
|
|
1229 "Cancel a check-out and get a fresh copy of the file"
|
|
|
1230 (delete-file file)
|
|
|
1231 (sc-do-command "*CVS*" "cvs update" cvs-program file file "update"))
|
|
|
1232
|
|
|
1233 (defun sc-cvs-update-directory ()
|
|
|
1234 "Update the current directory by calling cvs-update from pcl-cvs"
|
|
|
1235 (interactive)
|
|
|
1236 (cvs-update default-directory))
|
|
|
1237
|
|
|
1238 (defun sc-cvs-file-status ()
|
|
|
1239 "Show the CVS status of the current file"
|
|
|
1240 (interactive)
|
|
|
1241 (if (not buffer-file-name)
|
|
|
1242 (error "There is no file associated with buffer %s" (buffer-name)))
|
|
|
1243 (let ((file buffer-file-name))
|
|
|
1244 (sc-do-command "*CVS*" "cvs status" cvs-program file file "status" "-v"))
|
|
|
1245 (save-excursion
|
|
|
1246 (set-buffer "*CVS*")
|
|
|
1247 (goto-char (point-min)))
|
|
|
1248 (display-buffer "*CVS*"))
|
|
|
1249
|
|
|
1250
|
|
|
1251 ;;; ClearCase specific part
|
|
|
1252
|
|
|
1253 (defun ccase-is-registered-3 (fod)
|
|
|
1254 (if (or (not fod)
|
|
|
1255 (not (file-readable-p fod)))
|
|
|
1256 'na
|
|
|
1257 (let ((dirs sc-ccase-mfs-prefixes)
|
|
|
1258 (f nil)
|
|
|
1259 (file (expand-file-name fod)))
|
|
|
1260 (while (and (null f) dirs)
|
|
|
1261 (if (string-match (car dirs) file)
|
|
|
1262 (setq f t)
|
|
|
1263 (setq dirs (cdr dirs))))
|
|
|
1264 (if (null f)
|
|
|
1265 'na
|
|
|
1266 (sc-do-command "*CCase*" "describe" "cleartool" fod fod "describe")
|
|
|
1267 (save-excursion
|
|
|
1268 (set-buffer "*CCase*")
|
|
|
1269 (let ((s (buffer-string)))
|
|
|
1270 (cond
|
|
|
1271 ((string-match "@@" s) t)
|
|
|
1272 ((string-match "^Unix" s) 'na)
|
|
|
1273 (t nil)
|
|
|
1274 )))))))
|
|
|
1275
|
|
|
1276 (defun ccase-is-registered (fod)
|
|
|
1277 (eq (ccase-is-registered-3 fod) t))
|
|
|
1278
|
|
|
1279 (defun ccase-lock-info (file)
|
|
|
1280 (let ((cc (ccase-is-registered-3 file))
|
|
|
1281 s)
|
|
|
1282 (if (eq cc 't)
|
|
|
1283 (progn
|
|
|
1284 (save-excursion
|
|
|
1285 (set-buffer "*CCase*")
|
|
|
1286 (setq s (buffer-string)))
|
|
|
1287 (if (string-match "@@[^\n]*CHECKEDOUT\" from \\([^ ]*\\)[^\n]*\n[^\n]* by \\([^(\n]*\\) (" s)
|
|
|
1288 (list
|
|
|
1289 (substring s (match-beginning 1) (match-end 1))
|
|
|
1290 (substring s (match-beginning 2) (match-end 2)))
|
|
|
1291 (list nil nil)))
|
|
|
1292 cc)))
|
|
|
1293
|
|
|
1294 (defun ccase-maybe-comment (tag)
|
|
|
1295 (if (memq tag sc-ccase-comment-on)
|
|
|
1296 (sc-enter-comment)))
|
|
|
1297
|
|
|
1298 (defun ccase-register (file revision)
|
|
|
1299 "Registers the file. We don't support the revision argument.
|
|
|
1300 Also, we have to checkout the directory first."
|
|
|
1301 ;; probably need proper error handling to catch the
|
|
|
1302 ;; cases where we co the directory, but don't get to
|
|
|
1303 ;; ci it back (want to uco in this case)
|
|
|
1304 (let ((dpath (file-name-directory file)))
|
|
|
1305 (if (not (ccase-is-registered dpath))
|
|
|
1306 (error "Cannot register file outside of VOB")
|
|
|
1307 (sc-do-command "*CCase*" "co - dir" "cleartool" dpath dpath "co")
|
|
|
1308 (sc-do-command "*CCase*" "register" "cleartool" file file "mkelem")
|
|
|
1309 (sc-do-command "*CCase*" "ci - dir" "cleartool" dpath dpath "ci"))))
|
|
|
1310
|
|
|
1311 (defun ccase-check-out (file lockp)
|
|
|
1312 "Checks out the latest version of FILE.
|
|
|
1313 If LOCKP is not NIL, FILE is also locked."
|
|
|
1314 (let ((comment (ccase-maybe-comment 'checkout)))
|
|
|
1315 (sc-do-command "*CCase*" "co" "cleartool" file file "co"
|
|
|
1316 (if comment "-c" "-nc")
|
|
|
1317 (if comment comment)
|
|
|
1318 ;; this locking does not correspond to what we actually want. It's a
|
|
|
1319 ;; hack from the days when this was SCCS-only
|
|
|
1320 (if (ccase-reserve-p) "-res" "-unr"))
|
|
|
1321 ))
|
|
|
1322
|
|
|
1323 (defun ccase-reserve-p ()
|
|
|
1324 "Determine whether the user wants a reserved or unreserved checkout"
|
|
|
1325 (cond
|
|
|
1326 ((eq sc-ccase-reserve t) t)
|
|
|
1327 ((eq sc-ccase-reserve nil) nil)
|
|
|
1328 (t (y-or-n-p "Reserve Checkout? "))))
|
|
|
1329
|
|
|
1330 (defun ccase-get-version (file buffer revision)
|
|
|
1331 "Insert a previous revison of FILE in BUFFER.
|
|
|
1332 REVISION is the revision number requested."
|
|
|
1333 (save-excursion
|
|
|
1334 (set-buffer buffer)
|
|
|
1335 (delete-region (point-min) (point-max))
|
|
|
1336 (insert-file-contents (concat file "@@/" revision)))
|
|
|
1337 )
|
|
|
1338
|
|
|
1339 (defun ccase-check-in (file revision message)
|
|
|
1340 "Check in FILE with revision REVISION.
|
|
|
1341 MESSAGE is a string describing the changes."
|
|
|
1342 ;; we ignore revision since we can't use it
|
|
|
1343 (sc-do-command "*CCase*" "ci" "cleartool" file file "ci" "-c" message (if sc-mode-expert "-ide"))
|
|
|
1344 )
|
|
|
1345
|
|
|
1346 (defun ccase-history (file)
|
|
|
1347 "Insert the edit history of FILE in the current buffer."
|
|
|
1348 (sc-do-command (buffer-name) "history" "cleartool" file file "lsh")
|
|
|
1349 )
|
|
|
1350
|
|
|
1351 (defun ccase-tree-list ()
|
|
|
1352 "List in the current buffer the files registered in the source control system"
|
|
|
1353 ;;; This isn't going to fly as a practicality. We abstract everything out.
|
|
|
1354 ;; (sc-do-command (buffer-name) "listing" "cleartool" (default-directory) (default-directory) "ls" "-r" "-short" "-vis" "-nxname")
|
|
|
1355 )
|
|
|
1356
|
|
|
1357 (defun ccase-new-revision-p (file)
|
|
|
1358 "True if a new revision of FILE was checked in since we last got a copy of it"
|
|
|
1359 (save-excursion
|
|
|
1360 (let (pos newfile res br1 br2)
|
|
|
1361 (sc-do-command "*CCase*" "Describe" "cleartool" file file "des")
|
|
|
1362 (set-buffer "*CCase*")
|
|
|
1363 (goto-char (point-min))
|
|
|
1364 (if (setq pos (search-forward-regexp "@@\\([^ \"]*\\)CHECKEDOUT\" from \\([^ ]*\\) (\\([a-z]*\\))" nil t))
|
|
|
1365 ;; (if (setq pos (search-forward-regexp "@@\\([^ \"]*\\)CHECKEDOUT\"" nil t))
|
|
|
1366 (progn
|
|
|
1367 (setq res (buffer-substring (match-beginning 3) (match-end 3)))
|
|
|
1368 (if (equal res "unreserved")
|
|
|
1369 (progn
|
|
|
1370 (setq newfile (concat file "@@"
|
|
|
1371 (buffer-substring (match-beginning 1)
|
|
|
1372 (match-end 1))
|
|
|
1373 "LATEST"))
|
|
|
1374 (setq br1 (buffer-substring (match-beginning 2) (match-end 2)))
|
|
|
1375 (sc-do-command "*CCase*" "Describe" "cleartool" file newfile
|
|
|
1376 "des")
|
|
|
1377 (search-forward-regexp "@@\\([^ \"]*\\)" nil t)
|
|
|
1378 (setq br2 (buffer-substring (match-beginning 1) (match-end 1)))
|
|
|
1379 (not (equal br1 br2)))
|
|
|
1380 nil))
|
|
|
1381 (error "%s not currently checked out" file)))))
|
|
|
1382
|
|
|
1383 (defun ccase-revert (file)
|
|
|
1384 "Cancel a check out of FILE and get back the latest checked in version"
|
|
|
1385 (sc-do-command "*CCase*" "uco" "cleartool" file file "unco")
|
|
|
1386 )
|
|
|
1387
|
|
|
1388 (defun ccase-rename (old new)
|
|
|
1389 "Rename the source control archives for OLD to NEW"
|
|
|
1390 (let ((dpath (file-name-directory old))
|
|
|
1391 (comment (ccase-maybe-comment 'rename)))
|
|
|
1392 (if (not (ccase-is-registered dpath))
|
|
|
1393 (error "Cannot rename file outside of VOB")
|
|
|
1394 (sc-do-command "*CCase*" "co - dir" "cleartool" dpath dpath "co"
|
|
|
1395 (if comment "-c" "-nc")
|
|
|
1396 (if comment comment))
|
|
|
1397 (sc-do-command "*CCase*" "mv" "cleartool" new new "mv"
|
|
|
1398 (if comment "-c" "-nc")
|
|
|
1399 (if comment comment)
|
|
|
1400 old)
|
|
|
1401 (sc-do-command "*CCase*" "ci - dir" "cleartool" dpath dpath "ci"
|
|
|
1402 (if comment "-c" "-nc")
|
|
|
1403 (if comment comment)))))
|
|
|
1404
|
|
|
1405 (defun sc-ccase-checkout-dir ()
|
|
|
1406 "Checkout the directory this file is in"
|
|
|
1407 (interactive)
|
|
|
1408 (let ((dpath default-directory)
|
|
|
1409 (comment (ccase-maybe-comment 'checkout-dir)))
|
|
|
1410 (if (not (ccase-is-registered dpath))
|
|
|
1411 (error "Cannot checkout directory outside of VOB")
|
|
|
1412 (sc-do-command "*CCase*" "co - dir" "cleartool" dpath dpath "co"
|
|
|
1413 (if comment "-c" "-nc")
|
|
|
1414 (if comment comment)))))
|
|
|
1415
|
|
|
1416 (defun sc-ccase-checkin-dir ()
|
|
|
1417 "Checkin the directory this file is in"
|
|
|
1418 (interactive)
|
|
|
1419 (let ((dpath default-directory)
|
|
|
1420 (comment (ccase-maybe-comment 'checkin-dir)))
|
|
|
1421 (if (not (ccase-is-registered dpath))
|
|
|
1422 (error "Cannot checkout directory outside of VOB")
|
|
|
1423 (sc-do-command "*CCase*" "ci - dir" "cleartool" dpath dpath "ci"
|
|
|
1424 (if comment "-c" "-nc")
|
|
|
1425 (if comment comment)))))
|
|
|
1426
|
|
|
1427 (defun sc-ccase-editcs ()
|
|
|
1428 "Edit Config Spec for this view"
|
|
|
1429 (interactive)
|
|
|
1430 (sc-do-command "*CCase-cs*" "catcs" "cleartool" "" nil "catcs")
|
|
|
1431 (switch-to-buffer-other-window "*CCase-cs*")
|
|
|
1432 (local-set-key "\C-c\C-c" 'exit-recursive-edit)
|
|
|
1433 (recursive-edit)
|
|
|
1434 (set-buffer "*CCase-cs*")
|
|
|
1435 (let ((name (make-temp-name "/tmp/configspec")))
|
|
|
1436 (write-region (point-min) (point-max) name)
|
|
|
1437 (kill-buffer "*CCase-cs*")
|
|
|
1438 (sc-do-command "*CCase*" "setcs" "cleartool" name name "setcs"))
|
|
|
1439 )
|
|
|
1440
|
|
|
1441 (defun sc-ccase-new-brtype (brt)
|
|
|
1442 "Create a new branch type"
|
|
|
1443 (interactive "sBranch Name: ")
|
|
|
1444 (let ((comment (ccase-maybe-comment 'new-brtype)))
|
|
|
1445 (sc-do-command "*CCase*" "mkbrt" "cleartool" brt brt "mkbrtype"
|
|
|
1446 (if comment "-c" "-nc")
|
|
|
1447 (if comment comment))))
|
|
|
1448
|
|
|
1449 (defun sc-ccase-new-branch (brch)
|
|
|
1450 "Create a new branch for element"
|
|
|
1451 (interactive "sBranch: ")
|
|
|
1452 (let ((file (buffer-file-name))
|
|
|
1453 (comment (ccase-maybe-comment 'new-branch)))
|
|
|
1454 (sc-do-command "*CCase*" "mkbrch" "cleartool" file file "mkbranch"
|
|
|
1455 (if comment "-c" "-nc")
|
|
|
1456 (if comment comment)
|
|
|
1457 brch)))
|
|
|
1458
|
|
|
1459 (defun sc-ccase-checkin-merge ()
|
|
|
1460 "Merge in changes to enable checkin"
|
|
|
1461 (interactive)
|
|
|
1462 (save-excursion
|
|
|
1463 (let ((file (buffer-file-name))
|
|
|
1464 (buf (current-buffer))
|
|
|
1465 (comment (ccase-maybe-comment 'checkin-merge)))
|
|
|
1466 (sc-do-command "*CCase*" "Describe" "cleartool" file file "des")
|
|
|
1467 (set-buffer "*CCase*")
|
|
|
1468 (goto-char (point-min))
|
|
|
1469 (if (search-forward-regexp "@@\\([^ \"]*\\)CHECKEDOUT\" from \\([^ ]*\\) (\\([a-z]*\\))" nil t)
|
|
|
1470 (progn
|
|
|
1471 (sc-do-command "*CCase*" "Merging" "cleartool" file
|
|
|
1472 (concat (buffer-substring (match-beginning 1)
|
|
|
1473 (match-end 1)) "LATEST")
|
|
|
1474 "merge"
|
|
|
1475 (if comment "-c" "-nc")
|
|
|
1476 (if comment comment)
|
|
|
1477 "-abort" "-to" file "-ver")
|
|
|
1478 (set-buffer buf)
|
|
|
1479 (revert-buffer t t)
|
|
|
1480 (display-buffer "*CCase*"))
|
|
|
1481 (error "File %s not checked out" file)))))
|
|
|
1482
|
|
|
1483 (defun sc-ccase-version-tree ()
|
|
|
1484 "List version tree for file"
|
|
|
1485 (interactive)
|
|
|
1486 (let ((p (buffer-file-name)))
|
|
|
1487 (sc-do-command "*CCase*" "lsvtree" "cleartool" p p "lsvtree")
|
|
|
1488 (display-buffer "*CCase*")))
|
|
|
1489
|
|
|
1490 (defun ccase-protect-expanded-name (revision)
|
|
|
1491 "Protect ccase extended names from being used as temp names. Munge /s into :s"
|
|
|
1492 (if (equal sc-generic-name "CCase")
|
|
|
1493 (progn
|
|
|
1494 (if (string-match "/" revision)
|
|
|
1495 (let ((str (substring revision 0)) ;; copy string
|
|
|
1496 i)
|
|
|
1497 (while (setq i (string-match "/" str))
|
|
|
1498 (aset str i 58)) ; 58 is for :
|
|
|
1499 str)))))
|
|
|
1500
|
|
|
1501 (defun sc-ccase-list-locked-files ()
|
|
|
1502 (interactive)
|
|
|
1503 (sc-do-command "*CCase directory*" "listing" "cleartool" (default-directory) nil "lsco" "-cview"))
|
|
|
1504
|
|
|
1505 (defun sc-ccase-list-all-locked-files ()
|
|
|
1506 (interactive)
|
|
|
1507 (sc-do-command "*CCase directory*" "listing" "cleartool" (default-directory) nil "lsco"))
|
|
|
1508
|
|
|
1509 (defun sc-ccase-list-registered-files ()
|
|
|
1510 "List files registered in clearcase"
|
|
|
1511 (interactive)
|
|
|
1512 (sc-do-command "*CCase directory*" "listing" "cleartool" (default-directory) nil "ls" "-r" "-vis" "-nxname"))
|
|
|
1513
|
|
|
1514 ;;; Instantiation and installation of the menus
|
|
|
1515
|
|
|
1516 ;;; Set the menubar for Lucid Emacs
|
|
|
1517 (defvar sc-default-menu
|
|
|
1518 '(["NEXT-OPERATION" sc-next-operation t nil]
|
|
|
1519 ["Update Current Directory" sc-update-directory t]
|
|
|
1520 "----"
|
|
|
1521 ["Revert File" sc-revert-file t nil]
|
|
|
1522 ["Rename File" sc-rename-this-file t nil]
|
|
|
1523 "----"
|
|
|
1524 ["Show Changes" sc-show-changes t]
|
|
|
1525 ["Show Changes Since Revision..." sc-show-revision-changes t]
|
|
|
1526 ["Visit Previous Revision..." sc-visit-previous-revision t]
|
|
|
1527 ["Show Edit History" sc-show-history t]
|
|
|
1528 "----"
|
|
|
1529 ["List Locked Files" sc-list-locked-files t]
|
|
|
1530 ["List Locked Files Any User" sc-list-all-locked-files t]
|
|
|
1531 ["List Registered Files" sc-list-registered-files t])
|
|
|
1532 "Menubar entry for using the revision control system.")
|
|
|
1533
|
|
|
1534 (defvar sc-cvs-menu
|
|
|
1535 '(["Update Current Directory" sc-cvs-update-directory t]
|
|
|
1536 ["Revert File" sc-revert-file t nil]
|
|
|
1537 "----"
|
|
|
1538 ["Show Changes" sc-show-changes t]
|
|
|
1539 ["Show Changes Since Revision..." sc-show-revision-changes t]
|
|
|
1540 ["Visit Previous Revision..." sc-visit-previous-revision t]
|
|
|
1541 ["Show File Status" sc-cvs-file-status t]
|
|
|
1542 ["Show Edit History" sc-show-history t])
|
|
|
1543 "Menubar entry for using the revision control system with CVS.")
|
|
|
1544
|
|
|
1545 (defvar sc-ccase-menu
|
|
|
1546 '(["NEXT-OPERATION" sc-next-operation t nil]
|
|
|
1547 ["Revert File" sc-revert-file t nil]
|
|
|
1548 ["Checkin Merge" sc-ccase-checkin-merge t]
|
|
|
1549 "----"
|
|
|
1550 ["Show Changes" sc-show-changes t]
|
|
|
1551 ["Show Changes Since Revision..." sc-show-revision-changes t]
|
|
|
1552 ["Visit Previous Revision..." sc-visit-previous-revision t]
|
|
|
1553 ["Show Edit History" sc-show-history t]
|
|
|
1554 "----"
|
|
|
1555 ("Directories"
|
|
|
1556 ["Checkout Directory" sc-ccase-checkout-dir t]
|
|
|
1557 ["Checkin Directory" sc-ccase-checkin-dir t]
|
|
|
1558 ["Rename File..." sc-rename-this-file t nil])
|
|
|
1559 ("Configs"
|
|
|
1560 ["Edit Config Spec..." sc-ccase-editcs t]
|
|
|
1561 ["Create New Branch..." sc-ccase-new-brtype t]
|
|
|
1562 ["Make New Branch..." sc-ccase-new-branch t])
|
|
|
1563 ("Listings"
|
|
|
1564 ["List Version Tree" sc-ccase-version-tree t]
|
|
|
1565 ["List Locked Files" sc-ccase-list-locked-files t]
|
|
|
1566 ["List Locked Files Any User" sc-ccase-list-all-locked-files t]
|
|
|
1567 ["List Registered Files" sc-ccase-list-registered-files t]
|
|
|
1568 ))
|
|
|
1569 "Menubar entry for using the revision control system.")
|
|
|
1570
|
|
|
1571 (defun sc-sensitize-menu ()
|
|
|
1572 (let* ((rest (cdr (car
|
|
|
1573 (find-menu-item current-menubar (list sc-generic-name)))))
|
|
|
1574 (case-fold-search t)
|
|
|
1575 (file (if buffer-file-name
|
|
|
1576 (file-name-nondirectory buffer-file-name)
|
|
|
1577 (buffer-name)))
|
|
|
1578 (dir (file-name-directory
|
|
|
1579 (if buffer-file-name buffer-file-name default-directory)))
|
|
|
1580 (lock-info (sc-lock-info buffer-file-name))
|
|
|
1581 command
|
|
|
1582 nested-rest
|
|
|
1583 item)
|
|
|
1584 (while rest
|
|
|
1585 (setq item (car rest))
|
|
|
1586 (if (listp item)
|
|
|
1587 (progn
|
|
|
1588 (setq nested-rest (cons (cdr rest) nested-rest))
|
|
|
1589 (setq rest (cdr item)))
|
|
|
1590 (if (vectorp item)
|
|
|
1591 (progn
|
|
|
1592 (setq command (aref item 1))
|
|
|
1593 (cond ((eq 'sc-next-operation command)
|
|
|
1594 (aset item 0
|
|
|
1595 (cond ((eq lock-info 'na) "Not Available")
|
|
|
1596 ((not lock-info) "Register File")
|
|
|
1597 ((not (car lock-info)) "Check out File")
|
|
|
1598 (t "Check in File")))
|
|
|
1599 ;; if locked by somebody else disable the next-operation
|
|
|
1600 (if (or (not buffer-file-name)
|
|
|
1601 (eq lock-info 'na)
|
|
|
1602 (and (car lock-info)
|
|
|
1603 (not (equal sc-generic-name "CCase"))
|
|
|
1604 (not (equal (car lock-info) (user-login-name)))))
|
|
|
1605 (aset item 2 ())
|
|
|
1606 (aset item 2 t)))
|
|
|
1607 ((eq lock-info 'na) (aset item 2 ()))
|
|
|
1608 ((> (length item) 3)
|
|
|
1609 (aset item 3 file))
|
|
|
1610 (t nil))
|
|
|
1611 (if (not (eq lock-info 'na))
|
|
|
1612 (let ((enable-file-items
|
|
|
1613 (if (member sc-generic-name '("CVS" "CCase"))
|
|
|
1614 buffer-file-name
|
|
|
1615 (if lock-info t ()))))
|
|
|
1616 (if (memq command
|
|
|
1617 '(sc-force-check-in-file
|
|
|
1618 sc-register-file
|
|
|
1619 sc-revert-file
|
|
|
1620 sc-rename-this-file
|
|
|
1621 sc-show-history
|
|
|
1622 sc-show-changes
|
|
|
1623 sc-show-revision-changes
|
|
|
1624 sc-visit-previous-revision
|
|
|
1625 sc-cvs-file-status
|
|
|
1626 sc-ccase-checkout-dir
|
|
|
1627 sc-ccase-checkin-dir
|
|
|
1628 sc-ccase-editcs
|
|
|
1629 sc-ccase-new-brtype
|
|
|
1630 sc-ccase-new-branch
|
|
|
1631 sc-ccase-checkin-merge
|
|
|
1632 sc-ccase-needs-merge
|
|
|
1633 sc-ccase-merge-changes
|
|
|
1634 sc-ccase-create-label
|
|
|
1635 sc-ccase-label-sources
|
|
|
1636 sc-ccase-version-tree
|
|
|
1637 sc-list-locked-files
|
|
|
1638 sc-list-all-locked-files
|
|
|
1639 sc-ccase-list-registered-files
|
|
|
1640 ))
|
|
|
1641 (aset item 2 enable-file-items))))))
|
|
|
1642 (if (not (setq rest (cdr rest)))
|
|
|
1643 (if nested-rest
|
|
|
1644 (progn
|
|
|
1645 (setq rest (car nested-rest))
|
|
|
1646 (setq nested-rest (cdr nested-rest)))))))
|
|
|
1647 nil))
|
|
|
1648
|
|
|
1649
|
|
|
1650 ;;; Function to decide which Source control to use
|
|
|
1651 (defun sc-set-SCCS-mode ()
|
|
|
1652 (setq sc-generic-name "SCCS")
|
|
|
1653 (setq sc-can-hack-dir t)
|
|
|
1654 (setq sc-generic-lock-info 'sccs-lock-info)
|
|
|
1655 (setq sc-generic-register 'sccs-register)
|
|
|
1656 (setq sc-generic-check-out 'sccs-check-out)
|
|
|
1657 (setq sc-generic-get-version 'sccs-get-version)
|
|
|
1658 (setq sc-generic-check-in 'sccs-check-in)
|
|
|
1659 (setq sc-generic-history 'sccs-history)
|
|
|
1660 (setq sc-generic-tree-list 'sccs-tree-list)
|
|
|
1661 (setq sc-generic-new-revision-p 'sccs-new-revision-p)
|
|
|
1662 (setq sc-generic-revert 'sccs-revert)
|
|
|
1663 (setq sc-generic-rename 'sccs-rename)
|
|
|
1664 (setq sc-menu
|
|
|
1665 (cons (car sc-default-menu)
|
|
|
1666 (cons ["Insert Headers" sccs-insert-headers t]
|
|
|
1667 (cdr sc-default-menu))))
|
|
|
1668 (define-key sc-prefix-map "h" 'sccs-insert-headers)
|
|
|
1669 (define-key sc-prefix-map "\C-d" 'sc-update-directory))
|
|
|
1670
|
|
|
1671 (defun sc-set-RCS-mode ()
|
|
|
1672 (setq sc-generic-name "RCS")
|
|
|
1673 (setq sc-can-hack-dir t)
|
|
|
1674 (setq sc-generic-lock-info 'rcs-lock-info)
|
|
|
1675 (setq sc-generic-register 'rcs-register)
|
|
|
1676 (setq sc-generic-check-out 'rcs-check-out)
|
|
|
1677 (setq sc-generic-get-version 'rcs-get-version)
|
|
|
1678 (setq sc-generic-check-in 'rcs-check-in)
|
|
|
1679 (setq sc-generic-history 'rcs-history)
|
|
|
1680 (setq sc-generic-tree-list 'rcs-tree-list)
|
|
|
1681 (setq sc-generic-new-revision-p 'rcs-new-revision-p)
|
|
|
1682 (setq sc-generic-revert 'rcs-revert)
|
|
|
1683 (setq sc-generic-rename 'rcs-rename)
|
|
|
1684 (setq sc-menu sc-default-menu)
|
|
|
1685 (define-key sc-prefix-map "\C-d" 'sc-update-directory))
|
|
|
1686
|
|
|
1687 (defun sc-set-CVS-mode ()
|
|
|
1688 (require 'pcl-cvs)
|
|
|
1689 (setq sc-generic-name "CVS")
|
|
|
1690 (setq sc-can-hack-dir t)
|
|
|
1691 (setq sc-generic-lock-info 'cvs-lock-info)
|
|
|
1692 (setq sc-generic-register 'cvs-register)
|
|
|
1693 (setq sc-generic-check-out 'cvs-check-out)
|
|
|
1694 (setq sc-generic-get-version 'cvs-get-version)
|
|
|
1695 (setq sc-generic-check-in 'cvs-check-in)
|
|
|
1696 (setq sc-generic-history 'cvs-history)
|
|
|
1697 (setq sc-generic-tree-list 'cvs-tree-list)
|
|
|
1698 (setq sc-generic-new-revision-p 'cvs-new-revision-p)
|
|
|
1699 (setq sc-generic-revert 'cvs-revert)
|
|
|
1700 (setq sc-generic-rename 'cvs-rename)
|
|
|
1701 (setq sc-menu sc-cvs-menu)
|
|
|
1702 (define-key sc-prefix-map "\C-d" 'sc-cvs-update-directory)
|
|
|
1703 (define-key sc-prefix-map "s" 'sc-cvs-file-status))
|
|
|
1704
|
|
|
1705 (defun sc-set-CLEARCASE-mode ()
|
|
|
1706 (setq sc-generic-name "CCase")
|
|
|
1707 (setq sc-can-hack-dir nil)
|
|
|
1708 (setq sc-generic-lock-info 'ccase-lock-info)
|
|
|
1709 (setq sc-generic-register 'ccase-register)
|
|
|
1710 (setq sc-generic-check-out 'ccase-check-out)
|
|
|
1711 (setq sc-generic-get-version 'ccase-get-version)
|
|
|
1712 (setq sc-generic-check-in 'ccase-check-in)
|
|
|
1713 (setq sc-generic-history 'ccase-history)
|
|
|
1714 (setq sc-generic-tree-list 'ccase-tree-list)
|
|
|
1715 (setq sc-generic-new-revision-p 'ccase-new-revision-p)
|
|
|
1716 (setq sc-generic-revert 'ccase-revert)
|
|
|
1717 (setq sc-generic-rename 'ccase-rename)
|
|
|
1718 (setq sc-menu sc-ccase-menu)
|
|
|
1719
|
|
|
1720 ;; caching for file directory types
|
|
|
1721 (save-excursion
|
|
|
1722 (set-buffer (get-buffer-create "*CCase*"))
|
|
|
1723 (shell-command-on-region (point-min) (point-max) "df -t mfs | sed -n 's%.*[ ]\\(/[^ ]*\\)$%\\1%p'" t)
|
|
|
1724 (goto-char (point-min))
|
|
|
1725 (let (x l)
|
|
|
1726 (while (condition-case nil (setq x (read (current-buffer)))
|
|
|
1727 (error nil))
|
|
|
1728 (setq l (cons (prin1-to-string x) l)))
|
|
|
1729 (setq sc-ccase-mfs-prefixes (nreverse l))))
|
|
|
1730 )
|
|
|
1731
|
|
|
1732 (defun sc-set-ATRIA-mode ()
|
|
|
1733 (sc-set-CLEARCASE-mode))
|
|
|
1734
|
|
|
1735 (defun sc-set-CCASE-mode ()
|
|
|
1736 (sc-set-CLEARCASE-mode))
|
|
|
1737
|
|
|
1738
|
|
|
1739 ;; the module is sucessfully loaded!
|
|
|
1740 (provide 'generic-sc)
|
