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