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