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