Mercurial > emacs
comparison lisp/vc/vc-sccs.el @ 109404:e93288477c43
Merge from mainline.
author | Katsumi Yamaoka <yamaoka@jpl.org> |
---|---|
date | Sun, 13 Jun 2010 22:57:55 +0000 |
parents | lisp/vc-sccs.el@1918e70c8b37 lisp/vc-sccs.el@6ff48295959a |
children | 1b626601d32d |
comparison
equal
deleted
inserted
replaced
109403:681cd08dc0f7 | 109404:e93288477c43 |
---|---|
1 ;;; vc-sccs.el --- support for SCCS version-control | |
2 | |
3 ;; Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, | |
4 ;; 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 | |
5 ;; Free Software Foundation, Inc. | |
6 | |
7 ;; Author: FSF (see vc.el for full credits) | |
8 ;; Maintainer: Andre Spiegel <spiegel@gnu.org> | |
9 | |
10 ;; This file is part of GNU Emacs. | |
11 | |
12 ;; GNU Emacs is free software: you can redistribute it and/or modify | |
13 ;; it under the terms of the GNU General Public License as published by | |
14 ;; the Free Software Foundation, either version 3 of the License, or | |
15 ;; (at your option) any later version. | |
16 | |
17 ;; GNU Emacs is distributed in the hope that it will be useful, | |
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
20 ;; GNU General Public License for more details. | |
21 | |
22 ;; You should have received a copy of the GNU General Public License | |
23 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. | |
24 | |
25 ;;; Commentary: | |
26 | |
27 ;; Proper function of the SCCS diff commands requires the shellscript vcdiff | |
28 ;; to be installed somewhere on Emacs's path for executables. | |
29 ;; | |
30 | |
31 ;;; Code: | |
32 | |
33 (eval-when-compile | |
34 (require 'vc)) | |
35 | |
36 ;;; | |
37 ;;; Customization options | |
38 ;;; | |
39 | |
40 ;; ;; Maybe a better solution is to not use "get" but "sccs get". | |
41 ;; (defcustom vc-sccs-path | |
42 ;; (let ((path ())) | |
43 ;; (dolist (dir '("/usr/sccs" "/usr/lib/sccs" "/usr/libexec/sccs")) | |
44 ;; (if (file-directory-p dir) | |
45 ;; (push dir path))) | |
46 ;; path) | |
47 ;; "List of extra directories to search for SCCS commands." | |
48 ;; :type '(repeat directory) | |
49 ;; :group 'vc) | |
50 | |
51 (defcustom vc-sccs-register-switches nil | |
52 "Switches for registering a file in SCCS. | |
53 A string or list of strings passed to the checkin program by | |
54 \\[vc-register]. If nil, use the value of `vc-register-switches'. | |
55 If t, use no switches." | |
56 :type '(choice (const :tag "Unspecified" nil) | |
57 (const :tag "None" t) | |
58 (string :tag "Argument String") | |
59 (repeat :tag "Argument List" :value ("") string)) | |
60 :version "21.1" | |
61 :group 'vc) | |
62 | |
63 (defcustom vc-sccs-diff-switches nil | |
64 "String or list of strings specifying switches for SCCS diff under VC. | |
65 If nil, use the value of `vc-diff-switches'. If t, use no switches." | |
66 :type '(choice (const :tag "Unspecified" nil) | |
67 (const :tag "None" t) | |
68 (string :tag "Argument String") | |
69 (repeat :tag "Argument List" :value ("") string)) | |
70 :version "21.1" | |
71 :group 'vc) | |
72 | |
73 (defcustom vc-sccs-header (or (cdr (assoc 'SCCS vc-header-alist)) '("%W%")) | |
74 "Header keywords to be inserted by `vc-insert-headers'." | |
75 :type '(repeat string) | |
76 :group 'vc) | |
77 | |
78 ;;;###autoload | |
79 (defcustom vc-sccs-master-templates | |
80 (purecopy '("%sSCCS/s.%s" "%ss.%s" vc-sccs-search-project-dir)) | |
81 "Where to look for SCCS master files. | |
82 For a description of possible values, see `vc-check-master-templates'." | |
83 :type '(choice (const :tag "Use standard SCCS file names" | |
84 ("%sSCCS/s.%s" "%ss.%s" vc-sccs-search-project-dir)) | |
85 (repeat :tag "User-specified" | |
86 (choice string | |
87 function))) | |
88 :version "21.1" | |
89 :group 'vc) | |
90 | |
91 | |
92 ;;; | |
93 ;;; Internal variables | |
94 ;;; | |
95 | |
96 (defconst vc-sccs-name-assoc-file "VC-names") | |
97 | |
98 | |
99 ;;; Properties of the backend | |
100 | |
101 (defun vc-sccs-revision-granularity () 'file) | |
102 (defun vc-sccs-checkout-model (files) 'locking) | |
103 | |
104 ;;; | |
105 ;;; State-querying functions | |
106 ;;; | |
107 | |
108 ;; The autoload cookie below places vc-sccs-registered directly into | |
109 ;; loaddefs.el, so that vc-sccs.el does not need to be loaded for | |
110 ;; every file that is visited. The definition is repeated below | |
111 ;; so that Help and etags can find it. | |
112 | |
113 ;;;###autoload (defun vc-sccs-registered(f) (vc-default-registered 'SCCS f)) | |
114 (defun vc-sccs-registered (f) (vc-default-registered 'SCCS f)) | |
115 | |
116 (defun vc-sccs-state (file) | |
117 "SCCS-specific function to compute the version control state." | |
118 (if (not (vc-sccs-registered file)) | |
119 'unregistered | |
120 (with-temp-buffer | |
121 (if (vc-insert-file (vc-sccs-lock-file file)) | |
122 (let* ((locks (vc-sccs-parse-locks)) | |
123 (working-revision (vc-working-revision file)) | |
124 (locking-user (cdr (assoc working-revision locks)))) | |
125 (if (not locking-user) | |
126 (if (vc-workfile-unchanged-p file) | |
127 'up-to-date | |
128 'unlocked-changes) | |
129 (if (string= locking-user (vc-user-login-name file)) | |
130 'edited | |
131 locking-user))) | |
132 'up-to-date)))) | |
133 | |
134 (defun vc-sccs-state-heuristic (file) | |
135 "SCCS-specific state heuristic." | |
136 (if (not (vc-mistrust-permissions file)) | |
137 ;; This implementation assumes that any file which is under version | |
138 ;; control and has -rw-r--r-- is locked by its owner. This is true | |
139 ;; for both RCS and SCCS, which keep unlocked files at -r--r--r--. | |
140 ;; We have to be careful not to exclude files with execute bits on; | |
141 ;; scripts can be under version control too. Also, we must ignore the | |
142 ;; group-read and other-read bits, since paranoid users turn them off. | |
143 (let* ((attributes (file-attributes file 'string)) | |
144 (owner-name (nth 2 attributes)) | |
145 (permissions (nth 8 attributes))) | |
146 (if (string-match ".r-..-..-." permissions) | |
147 'up-to-date | |
148 (if (string-match ".rw..-..-." permissions) | |
149 (if (file-ownership-preserved-p file) | |
150 'edited | |
151 owner-name) | |
152 ;; Strange permissions. | |
153 ;; Fall through to real state computation. | |
154 (vc-sccs-state file)))) | |
155 (vc-sccs-state file))) | |
156 | |
157 (defun vc-sccs-dir-status (dir update-function) | |
158 ;; FIXME: this function should be rewritten, using `vc-expand-dirs' | |
159 ;; is not TRTD because it returns files from multiple backends. | |
160 ;; It should also return 'unregistered files. | |
161 | |
162 ;; Doing lots of individual VC-state calls is painful, but | |
163 ;; there is no better option in SCCS-land. | |
164 (let ((flist (vc-expand-dirs (list dir))) | |
165 (result nil)) | |
166 (dolist (file flist) | |
167 (let ((state (vc-state file)) | |
168 (frel (file-relative-name file))) | |
169 (when (and (eq (vc-backend file) 'SCCS) | |
170 (not (eq state 'up-to-date))) | |
171 (push (list frel state) result)))) | |
172 (funcall update-function result))) | |
173 | |
174 (defun vc-sccs-working-revision (file) | |
175 "SCCS-specific version of `vc-working-revision'." | |
176 (with-temp-buffer | |
177 ;; The working revision is always the latest revision number. | |
178 ;; To find this number, search the entire delta table, | |
179 ;; rather than just the first entry, because the | |
180 ;; first entry might be a deleted ("R") revision. | |
181 (vc-insert-file (vc-name file) "^\001e\n\001[^s]") | |
182 (vc-parse-buffer "^\001d D \\([^ ]+\\)" 1))) | |
183 | |
184 (defun vc-sccs-workfile-unchanged-p (file) | |
185 "SCCS-specific implementation of `vc-workfile-unchanged-p'." | |
186 (zerop (apply 'vc-do-command "*vc*" 1 "vcdiff" (vc-name file) | |
187 (list "--brief" "-q" | |
188 (concat "-r" (vc-working-revision file)))))) | |
189 | |
190 | |
191 ;;; | |
192 ;;; State-changing functions | |
193 ;;; | |
194 | |
195 (defun vc-sccs-do-command (buffer okstatus command file-or-list &rest flags) | |
196 ;; (let ((load-path (append vc-sccs-path load-path))) | |
197 ;; (apply 'vc-do-command buffer okstatus command file-or-list flags)) | |
198 (apply 'vc-do-command (or buffer "*vc*") okstatus "sccs" file-or-list command flags)) | |
199 | |
200 (defun vc-sccs-create-repo () | |
201 "Create a new SCCS repository." | |
202 ;; SCCS is totally file-oriented, so all we have to do is make the directory | |
203 (make-directory "SCCS")) | |
204 | |
205 (defun vc-sccs-register (files &optional rev comment) | |
206 "Register FILES into the SCCS version-control system. | |
207 REV is the optional revision number for the file. COMMENT can be used | |
208 to provide an initial description of FILES. | |
209 Passes either `vc-sccs-register-switches' or `vc-register-switches' | |
210 to the SCCS command. | |
211 | |
212 Automatically retrieve a read-only version of the files with keywords | |
213 expanded if `vc-keep-workfiles' is non-nil, otherwise, delete the workfile." | |
214 (dolist (file files) | |
215 (let* ((dirname (or (file-name-directory file) "")) | |
216 (basename (file-name-nondirectory file)) | |
217 (project-file (vc-sccs-search-project-dir dirname basename))) | |
218 (let ((vc-name | |
219 (or project-file | |
220 (format (car vc-sccs-master-templates) dirname basename)))) | |
221 (apply 'vc-sccs-do-command nil 0 "admin" vc-name | |
222 (and rev (not (string= rev "")) (concat "-r" rev)) | |
223 "-fb" | |
224 (concat "-i" (file-relative-name file)) | |
225 (and comment (concat "-y" comment)) | |
226 (vc-switches 'SCCS 'register))) | |
227 (delete-file file) | |
228 (if vc-keep-workfiles | |
229 (vc-sccs-do-command nil 0 "get" (vc-name file)))))) | |
230 | |
231 (defun vc-sccs-responsible-p (file) | |
232 "Return non-nil if SCCS thinks it would be responsible for registering FILE." | |
233 ;; TODO: check for all the patterns in vc-sccs-master-templates | |
234 (or (file-directory-p (expand-file-name "SCCS" (file-name-directory file))) | |
235 (stringp (vc-sccs-search-project-dir (or (file-name-directory file) "") | |
236 (file-name-nondirectory file))))) | |
237 | |
238 (defun vc-sccs-checkin (files rev comment &optional extra-args-ignored) | |
239 "SCCS-specific version of `vc-backend-checkin'." | |
240 (dolist (file (vc-expand-dirs files)) | |
241 (apply 'vc-sccs-do-command nil 0 "delta" (vc-name file) | |
242 (if rev (concat "-r" rev)) | |
243 (concat "-y" comment) | |
244 (vc-switches 'SCCS 'checkin)) | |
245 (if vc-keep-workfiles | |
246 (vc-sccs-do-command nil 0 "get" (vc-name file))))) | |
247 | |
248 (defun vc-sccs-find-revision (file rev buffer) | |
249 (apply 'vc-sccs-do-command | |
250 buffer 0 "get" (vc-name file) | |
251 "-s" ;; suppress diagnostic output | |
252 "-p" | |
253 (and rev | |
254 (concat "-r" | |
255 (vc-sccs-lookup-triple file rev))) | |
256 (vc-switches 'SCCS 'checkout))) | |
257 | |
258 (defun vc-sccs-checkout (file &optional editable rev) | |
259 "Retrieve a copy of a saved revision of SCCS controlled FILE. | |
260 If FILE is a directory, all version-controlled files beneath are checked out. | |
261 EDITABLE non-nil means that the file should be writable and | |
262 locked. REV is the revision to check out." | |
263 (if (file-directory-p file) | |
264 (mapc 'vc-sccs-checkout (vc-expand-dirs (list file))) | |
265 (let ((file-buffer (get-file-buffer file)) | |
266 switches) | |
267 (message "Checking out %s..." file) | |
268 (save-excursion | |
269 ;; Change buffers to get local value of vc-checkout-switches. | |
270 (if file-buffer (set-buffer file-buffer)) | |
271 (setq switches (vc-switches 'SCCS 'checkout)) | |
272 ;; Save this buffer's default-directory | |
273 ;; and use save-excursion to make sure it is restored | |
274 ;; in the same buffer it was saved in. | |
275 (let ((default-directory default-directory)) | |
276 (save-excursion | |
277 ;; Adjust the default-directory so that the check-out creates | |
278 ;; the file in the right place. | |
279 (setq default-directory (file-name-directory file)) | |
280 | |
281 (and rev (or (string= rev "") | |
282 (not (stringp rev))) | |
283 (setq rev nil)) | |
284 (apply 'vc-sccs-do-command nil 0 "get" (vc-name file) | |
285 (if editable "-e") | |
286 (and rev (concat "-r" (vc-sccs-lookup-triple file rev))) | |
287 switches)))) | |
288 (message "Checking out %s...done" file)))) | |
289 | |
290 (defun vc-sccs-rollback (files) | |
291 "Roll back, undoing the most recent checkins of FILES. Directories | |
292 are expanded to all version-controlled subfiles." | |
293 (setq files (vc-expand-dirs files)) | |
294 (if (not files) | |
295 (error "SCCS backend doesn't support directory-level rollback")) | |
296 (dolist (file files) | |
297 (let ((discard (vc-working-revision file))) | |
298 (if (null (yes-or-no-p (format "Remove version %s from %s history? " | |
299 discard file))) | |
300 (error "Aborted")) | |
301 (message "Removing revision %s from %s..." discard file) | |
302 (vc-sccs-do-command nil 0 "rmdel" | |
303 (vc-name file) (concat "-r" discard)) | |
304 (vc-sccs-do-command nil 0 "get" (vc-name file) nil)))) | |
305 | |
306 (defun vc-sccs-revert (file &optional contents-done) | |
307 "Revert FILE to the version it was based on. If FILE is a directory, | |
308 revert all subfiles." | |
309 (if (file-directory-p file) | |
310 (mapc 'vc-sccs-revert (vc-expand-dirs (list file))) | |
311 (vc-sccs-do-command nil 0 "unget" (vc-name file)) | |
312 (vc-sccs-do-command nil 0 "get" (vc-name file)) | |
313 ;; Checking out explicit revisions is not supported under SCCS, yet. | |
314 ;; We always "revert" to the latest revision; therefore | |
315 ;; vc-working-revision is cleared here so that it gets recomputed. | |
316 (vc-file-setprop file 'vc-working-revision nil))) | |
317 | |
318 (defun vc-sccs-steal-lock (file &optional rev) | |
319 "Steal the lock on the current workfile for FILE and revision REV." | |
320 (if (file-directory-p file) | |
321 (mapc 'vc-sccs-steal-lock (vc-expand-dirs (list file))) | |
322 (vc-sccs-do-command nil 0 "unget" | |
323 (vc-name file) "-n" (if rev (concat "-r" rev))) | |
324 (vc-sccs-do-command nil 0 "get" | |
325 (vc-name file) "-g" (if rev (concat "-r" rev))))) | |
326 | |
327 (defun vc-sccs-modify-change-comment (files rev comment) | |
328 "Modify (actually, append to) the change comments for FILES on a specified REV." | |
329 (dolist (file (vc-expand-dirs files)) | |
330 (vc-sccs-do-command nil 0 "cdc" (vc-name file) | |
331 (concat "-y" comment) (concat "-r" rev)))) | |
332 | |
333 | |
334 ;;; | |
335 ;;; History functions | |
336 ;;; | |
337 | |
338 (defun vc-sccs-print-log (files buffer &optional shortlog start-revision-ignored limit) | |
339 "Get change log associated with FILES." | |
340 (setq files (vc-expand-dirs files)) | |
341 (vc-sccs-do-command buffer 0 "prs" (mapcar 'vc-name files)) | |
342 (when limit 'limit-unsupported)) | |
343 | |
344 (defun vc-sccs-diff (files &optional oldvers newvers buffer) | |
345 "Get a difference report using SCCS between two filesets." | |
346 (setq files (vc-expand-dirs files)) | |
347 (setq oldvers (vc-sccs-lookup-triple (car files) oldvers)) | |
348 (setq newvers (vc-sccs-lookup-triple (car files) newvers)) | |
349 (apply 'vc-do-command (or buffer "*vc-diff*") | |
350 1 "vcdiff" (mapcar 'vc-name (vc-expand-dirs files)) | |
351 (append (list "-q" | |
352 (and oldvers (concat "-r" oldvers)) | |
353 (and newvers (concat "-r" newvers))) | |
354 (vc-switches 'SCCS 'diff)))) | |
355 | |
356 | |
357 ;;; | |
358 ;;; Tag system. SCCS doesn't have tags, so we simulate them by maintaining | |
359 ;;; our own set of name-to-revision mappings. | |
360 ;;; | |
361 | |
362 (defun vc-sccs-create-tag (backend dir name branchp) | |
363 (when branchp | |
364 (error "SCCS backend %s does not support module branches" backend)) | |
365 (let ((result (vc-tag-precondition dir))) | |
366 (if (stringp result) | |
367 (error "File %s is not up-to-date" result) | |
368 (vc-file-tree-walk | |
369 dir | |
370 (lambda (f) | |
371 (vc-sccs-add-triple name f (vc-working-revision f))))))) | |
372 | |
373 | |
374 ;;; | |
375 ;;; Miscellaneous | |
376 ;;; | |
377 | |
378 (defun vc-sccs-previous-revision (file rev) | |
379 (vc-call-backend 'RCS 'previous-revision file rev)) | |
380 | |
381 (defun vc-sccs-next-revision (file rev) | |
382 (vc-call-backend 'RCS 'next-revision file rev)) | |
383 | |
384 (defun vc-sccs-check-headers () | |
385 "Check if the current file has any headers in it." | |
386 (save-excursion | |
387 (goto-char (point-min)) | |
388 (re-search-forward "%[A-Z]%" nil t))) | |
389 | |
390 (defun vc-sccs-rename-file (old new) | |
391 ;; Move the master file (using vc-rcs-master-templates). | |
392 (vc-rename-master (vc-name old) new vc-sccs-master-templates) | |
393 ;; Update the tag file. | |
394 (with-current-buffer | |
395 (find-file-noselect | |
396 (expand-file-name vc-sccs-name-assoc-file | |
397 (file-name-directory (vc-name old)))) | |
398 (goto-char (point-min)) | |
399 ;; (replace-regexp (concat ":" (regexp-quote old) "$") (concat ":" new)) | |
400 (while (re-search-forward (concat ":" (regexp-quote old) "$") nil t) | |
401 (replace-match (concat ":" new) nil nil)) | |
402 (basic-save-buffer) | |
403 (kill-buffer (current-buffer)))) | |
404 | |
405 (defun vc-sccs-find-file-hook () | |
406 ;; If the file is locked by some other user, make | |
407 ;; the buffer read-only. Like this, even root | |
408 ;; cannot modify a file that someone else has locked. | |
409 (and (stringp (vc-state buffer-file-name 'SCCS)) | |
410 (setq buffer-read-only t))) | |
411 | |
412 | |
413 ;;; | |
414 ;;; Internal functions | |
415 ;;; | |
416 | |
417 ;; This function is wrapped with `progn' so that the autoload cookie | |
418 ;; copies the whole function itself into loaddefs.el rather than just placing | |
419 ;; a (autoload 'vc-sccs-search-project-dir "vc-sccs") which would not | |
420 ;; help us avoid loading vc-sccs. | |
421 ;;;###autoload | |
422 (progn (defun vc-sccs-search-project-dir (dirname basename) | |
423 "Return the name of a master file in the SCCS project directory. | |
424 Does not check whether the file exists but returns nil if it does not | |
425 find any project directory." | |
426 (let ((project-dir (getenv "PROJECTDIR")) dirs dir) | |
427 (when project-dir | |
428 (if (file-name-absolute-p project-dir) | |
429 (setq dirs '("SCCS" "")) | |
430 (setq dirs '("src/SCCS" "src" "source/SCCS" "source")) | |
431 (setq project-dir (expand-file-name (concat "~" project-dir)))) | |
432 (while (and (not dir) dirs) | |
433 (setq dir (expand-file-name (car dirs) project-dir)) | |
434 (unless (file-directory-p dir) | |
435 (setq dir nil) | |
436 (setq dirs (cdr dirs)))) | |
437 (and dir (expand-file-name (concat "s." basename) dir)))))) | |
438 | |
439 (defun vc-sccs-lock-file (file) | |
440 "Generate lock file name corresponding to FILE." | |
441 (let ((master (vc-name file))) | |
442 (and | |
443 master | |
444 (string-match "\\(.*/\\)\\(s\\.\\)\\(.*\\)" master) | |
445 (replace-match "p." t t master 2)))) | |
446 | |
447 (defun vc-sccs-parse-locks () | |
448 "Parse SCCS locks in current buffer. | |
449 The result is a list of the form ((REVISION . USER) (REVISION . USER) ...)." | |
450 (let (master-locks) | |
451 (goto-char (point-min)) | |
452 (while (re-search-forward "^\\([0-9.]+\\) [0-9.]+ \\([^ ]+\\) .*\n?" | |
453 nil t) | |
454 (setq master-locks | |
455 (cons (cons (match-string 1) (match-string 2)) master-locks))) | |
456 ;; FIXME: is it really necessary to reverse ? | |
457 (nreverse master-locks))) | |
458 | |
459 (defun vc-sccs-add-triple (name file rev) | |
460 (with-current-buffer | |
461 (find-file-noselect | |
462 (expand-file-name vc-sccs-name-assoc-file | |
463 (file-name-directory (vc-name file)))) | |
464 (goto-char (point-max)) | |
465 (insert name "\t:\t" file "\t" rev "\n") | |
466 (basic-save-buffer) | |
467 (kill-buffer (current-buffer)))) | |
468 | |
469 (defun vc-sccs-lookup-triple (file name) | |
470 "Return the numeric revision corresponding to a named tag of FILE. | |
471 If NAME is nil or a revision number string it's just passed through." | |
472 (if (or (null name) | |
473 (let ((firstchar (aref name 0))) | |
474 (and (>= firstchar ?0) (<= firstchar ?9)))) | |
475 name | |
476 (with-temp-buffer | |
477 (vc-insert-file | |
478 (expand-file-name vc-sccs-name-assoc-file | |
479 (file-name-directory (vc-name file)))) | |
480 (vc-parse-buffer (concat name "\t:\t" file "\t\\(.+\\)") 1)))) | |
481 | |
482 (provide 'vc-sccs) | |
483 | |
484 ;; arch-tag: d751dee3-d7b3-47e1-95e3-7ae98c052041 | |
485 ;;; vc-sccs.el ends here |