Mercurial > emacs
comparison lisp/vc-sccs.el @ 31385:b1e1a94dfc0a
(vc-sccs-latest-on-branch-p): Always return t; we
don't support anything else under SCCS yet.
(vc-sccs-update-changelog): Dummy implementation that
simply signals an error.
(vc-sccs-state-heuristic): Use
file-ownership-preserved-p.
(vc-sccs-workfile-unchanged-p): Fix call to
vc-do-command.
(vc-sccs-state-heuristic): Don't use file-writable-p.
(vc-sccs-workfile-unchanged-p): Fix parenthesis.
(vc-sccs-print-log, vc-sccs-diff): Insert in the current buffer.
(vc-sccs-workfile-unchanged-p): Rewritten.
(vc-sccs-diff): Remove optional arg CMP.
(vc-sccs-state): Call vc-workfile-unchanged-p, not the
SCCS-specific function.
(vc-sccs-state): Fix obviously wrong parenthesis.
(vc-sccs-state-heuristic): Use file-writable-p instead of
comparing userids.
(vc-sccs-checkout): Use `unless'.
(vc-sccs-state): Use with-temp-buffer.
(vc-sccs-workfile-version): Use with-temp-buffer and new
vc-parse-buffer and don't bother setting the property.
(vc-sccs-add-triple): Use with-current-buffer and
find-file-noselect.
(vc-sccs-lookup-triple): New vc-parse-buffer and turn cond -> if.
Merge in
code from vc-sccs-hooks.el.
(vc-sccs-release, vc-sccs-system-release): Remove. Don't require
'vc anymore.
(vc-sccs-responsible-p): Use expand-file-name instead of concat
and file-directory-p instead of file-exists-p.
(vc-sccs-check-headers): Simplify the regexp.
(vc-sccs-responsible-p, vc-sccs-register): Use
`vc-sccs-search-project-dir' instead of `vc-sccs-project-dir'.
(vc-sccs-header): New var.
(vc-sccs-rename-file): Renamed from
vc-sccs-record-rename. Use `find-file-noselect' rather than
`find-file' and call `vc-rename-master' to do the actual move.
(vc-sccs-diff): Remove unused `backend' variable.
(tail): Provide vc-sccs.
(vc-sccs-checkout): Removed call to
vc-file-clear-masterprops. If writable, set vc-state to 'edited
rather than user login name.
Require 'vc and 'vc-sccs-hooks.
(vc-sccs-register-switches): New var, copied off of vc-rcs-hooks.
(vc-sccs-latest-on-branch-p): Add a `FIXME' for a call to the
unknown `vc-latest-version' function. It should probably refer to
vc-workfile-version or somesuch, but it's very unclear to me and I
don't have SCCS to test things.
(vc-sccs-steal-lock): Renamed from `vc-sccs-steal'.
(vc-BACKEND-responsible-p): New
functions.
(vc-BACKEND-register): Renamed from `vc-BACKEND-admin'. Removed
query option. Redocumented.
(vc-sccs-diff): Function changed name from
`vc-backend-diff'. This makes `vc-diff' work.
(vc-sccs-release): Doc fix.
(vc-sccs-admin): Added the query-only option as
required by the vc.el file.
(vc-sccs-latest-on-branch-p): Function added.
(vc-sccs-diff): Function added.
(vc-sccs-checkout): Added function `vc-sccs-checkout'.
Require vc when compiling.
(vc-sccs-print-log, vc-sccs-assign-name, vc-sccs-merge)
(vc-sccs-check-headers, vc-sccs-steal, vc-sccs-uncheck)
(vc-sccs-revert)
(vc-sccs-checkin, vc-sccs-logentry-check): New functions (code
from vc.el).
(vc-sccs-add-triple, vc-sccs-record-rename)
(vc-sccs-lookup-triple): Moved from vc.el and renamed.
(vc-sccs-admin): Doc fix.
(vc-admin-sccs): Added from vc.el
(vc-sccs-system-release):
Renamed from vc-sccs-backend-release.
(vc-sccs-release): Moved from vc.el.
(vc-sccs-backend-release): New function.
author | Gerd Moellmann <gerd@gnu.org> |
---|---|
date | Mon, 04 Sep 2000 19:48:23 +0000 |
parents | |
children | f2ab9420390f |
comparison
equal
deleted
inserted
replaced
31384:f6cb7dfe5e7c | 31385:b1e1a94dfc0a |
---|---|
1 ;;; vc-sccs.el --- support for SCCS version-control | |
2 | |
3 ;; Copyright (C) 1992,93,94,95,96,97,98,99,2000 Free Software Foundation, Inc. | |
4 | |
5 ;; Author: FSF (see vc.el for full credits) | |
6 ;; Maintainer: Andre Spiegel <spiegel@gnu.org> | |
7 | |
8 ;; $Id: vc-sccs.el,v 1.35 2000/08/13 11:52:19 spiegel Exp $ | |
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 2, or (at your option) | |
15 ;; 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; see the file COPYING. If not, write to the | |
24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
25 ;; Boston, MA 02111-1307, USA. | |
26 | |
27 ;;; Commentary: | |
28 | |
29 ;;; Code: | |
30 | |
31 (defcustom vc-sccs-register-switches nil | |
32 "*A string or list of strings; extra switches for registering a file | |
33 in |SCCS. These are passed to the checkin program by | |
34 \\[vc-sccs-register]." | |
35 :type '(choice (const :tag "None" nil) | |
36 (string :tag "Argument String") | |
37 (repeat :tag "Argument List" | |
38 :value ("") | |
39 string)) | |
40 :group 'vc) | |
41 | |
42 (defcustom vc-sccs-header (or (cdr (assoc 'SCCS vc-header-alist)) '("%W%")) | |
43 "*Header keywords to be inserted by `vc-insert-headers'." | |
44 :type 'string | |
45 :group 'vc) | |
46 | |
47 ;;;###autoload | |
48 (defcustom vc-sccs-master-templates | |
49 '("%sSCCS/s.%s" "%ss.%s" vc-sccs-search-project-dir) | |
50 "*Where to look for SCCS master files. | |
51 For a description of possible values, see `vc-check-master-templates'." | |
52 :type '(choice (const :tag "Use standard SCCS file names" | |
53 ("%sSCCS/s.%s" "%ss.%s" vc-sccs-search-project-dir)) | |
54 (repeat :tag "User-specified" | |
55 (choice string | |
56 function))) | |
57 :version "20.5" | |
58 :group 'vc) | |
59 | |
60 ;;;###autoload | |
61 (progn (defun vc-sccs-registered (f) (vc-default-registered 'SCCS f))) | |
62 | |
63 (defun vc-sccs-state (file) | |
64 "SCCS-specific function to compute the version control state." | |
65 (with-temp-buffer | |
66 (if (vc-insert-file (vc-sccs-lock-file file)) | |
67 (let* ((locks (vc-sccs-parse-locks)) | |
68 (workfile-version (vc-workfile-version file)) | |
69 (locking-user (cdr (assoc workfile-version locks)))) | |
70 (if (not locking-user) | |
71 (if (vc-workfile-unchanged-p file) | |
72 'up-to-date | |
73 'unlocked-changes) | |
74 (if (string= locking-user (vc-user-login-name)) | |
75 'edited | |
76 locking-user))) | |
77 'up-to-date))) | |
78 | |
79 (defun vc-sccs-state-heuristic (file) | |
80 "SCCS-specific state heuristic." | |
81 (if (not (vc-mistrust-permissions file)) | |
82 ;; This implementation assumes that any file which is under version | |
83 ;; control and has -rw-r--r-- is locked by its owner. This is true | |
84 ;; for both RCS and SCCS, which keep unlocked files at -r--r--r--. | |
85 ;; We have to be careful not to exclude files with execute bits on; | |
86 ;; scripts can be under version control too. Also, we must ignore the | |
87 ;; group-read and other-read bits, since paranoid users turn them off. | |
88 (let* ((attributes (file-attributes file)) | |
89 (owner-uid (nth 2 attributes)) | |
90 (permissions (nth 8 attributes))) | |
91 (if (string-match ".r-..-..-." permissions) | |
92 'up-to-date | |
93 (if (string-match ".rw..-..-." permissions) | |
94 (if (file-ownership-preserved-p file) | |
95 'edited | |
96 (vc-user-login-name owner-uid)) | |
97 ;; Strange permissions. | |
98 ;; Fall through to real state computation. | |
99 (vc-sccs-state file))) | |
100 (vc-sccs-state file)))) | |
101 | |
102 (defun vc-sccs-workfile-version (file) | |
103 "SCCS-specific version of `vc-workfile-version'." | |
104 (with-temp-buffer | |
105 (vc-insert-file (vc-name file) "^\001e") | |
106 (vc-parse-buffer "^\001d D \\([^ ]+\\)" 1))) | |
107 | |
108 (defun vc-sccs-checkout-model (file) | |
109 "SCCS-specific version of `vc-checkout-model'." | |
110 'locking) | |
111 | |
112 (defun vc-sccs-workfile-unchanged-p (file) | |
113 "SCCS-specific implementation of vc-workfile-unchanged-p." | |
114 (apply 'vc-do-command nil 1 "vcdiff" (vc-name file) | |
115 (list "--brief" "-q" | |
116 (concat "-r" (vc-workfile-version file))))) | |
117 | |
118 ;; internal code | |
119 | |
120 ;; This function is wrapped with `progn' so that the autoload cookie | |
121 ;; copies the whole function itself into loaddefs.el rather than just placing | |
122 ;; a (autoload 'vc-sccs-search-project-dir "vc-sccs") which would not | |
123 ;; help us avoid loading vc-sccs. | |
124 ;;;###autoload | |
125 (progn (defun vc-sccs-search-project-dir (dirname basename) | |
126 "Return the name of a master file in the SCCS project directory. | |
127 Does not check whether the file exists but returns nil if it does not | |
128 find any project directory." | |
129 (let ((project-dir (getenv "PROJECTDIR")) dirs dir) | |
130 (when project-dir | |
131 (if (file-name-absolute-p project-dir) | |
132 (setq dirs '("SCCS" "")) | |
133 (setq dirs '("src/SCCS" "src" "source/SCCS" "source")) | |
134 (setq project-dir (expand-file-name (concat "~" project-dir)))) | |
135 (while (and (not dir) dirs) | |
136 (setq dir (expand-file-name (car dirs) project-dir)) | |
137 (unless (file-directory-p dir) | |
138 (setq dir nil) | |
139 (setq dirs (cdr dirs)))) | |
140 (and dir (expand-file-name (concat "s." basename) dir)))))) | |
141 | |
142 (defun vc-sccs-lock-file (file) | |
143 "Generate lock file name corresponding to FILE." | |
144 (let ((master (vc-name file))) | |
145 (and | |
146 master | |
147 (string-match "\\(.*/\\)\\(s\\.\\)\\(.*\\)" master) | |
148 (replace-match "p." t t master 2)))) | |
149 | |
150 (defun vc-sccs-parse-locks () | |
151 "Parse SCCS locks in current buffer. | |
152 The result is a list of the form ((VERSION . USER) (VERSION . USER) ...)." | |
153 (let (master-locks) | |
154 (goto-char (point-min)) | |
155 (while (re-search-forward "^\\([0-9.]+\\) [0-9.]+ \\([^ ]+\\) .*\n?" | |
156 nil t) | |
157 (setq master-locks | |
158 (cons (cons (match-string 1) (match-string 2)) master-locks))) | |
159 ;; FIXME: is it really necessary to reverse ? | |
160 (nreverse master-locks))) | |
161 | |
162 (defun vc-sccs-print-log (file) | |
163 "Get change log associated with FILE." | |
164 (vc-do-command t 0 "prs" (vc-name file))) | |
165 | |
166 (defun vc-sccs-assign-name (file name) | |
167 "Assign to FILE's latest version a given NAME." | |
168 (vc-sccs-add-triple name file (vc-workfile-version file))) | |
169 | |
170 ;; Named-configuration support | |
171 | |
172 (defun vc-sccs-add-triple (name file rev) | |
173 (with-current-buffer | |
174 (find-file-noselect | |
175 (expand-file-name vc-name-assoc-file | |
176 (file-name-directory (vc-name file)))) | |
177 (goto-char (point-max)) | |
178 (insert name "\t:\t" file "\t" rev "\n") | |
179 (basic-save-buffer) | |
180 (kill-buffer (current-buffer)))) | |
181 | |
182 (defun vc-sccs-rename-file (old new) | |
183 ;; Move the master file (using vc-rcs-master-templates). | |
184 (vc-rename-master (vc-name old) new vc-sccs-master-templates) | |
185 ;; Update the snapshot file. | |
186 (with-current-buffer | |
187 (find-file-noselect | |
188 (expand-file-name vc-name-assoc-file | |
189 (file-name-directory (vc-name old)))) | |
190 (goto-char (point-min)) | |
191 ;; (replace-regexp (concat ":" (regexp-quote old) "$") (concat ":" new)) | |
192 (while (re-search-forward (concat ":" (regexp-quote old) "$") nil t) | |
193 (replace-match (concat ":" new) nil nil)) | |
194 (basic-save-buffer) | |
195 (kill-buffer (current-buffer)))) | |
196 | |
197 (defun vc-sccs-lookup-triple (file name) | |
198 "Return the numeric version corresponding to a named snapshot of FILE. | |
199 If NAME is nil or a version number string it's just passed through." | |
200 (if (or (null name) | |
201 (let ((firstchar (aref name 0))) | |
202 (and (>= firstchar ?0) (<= firstchar ?9)))) | |
203 name | |
204 (with-temp-buffer | |
205 (vc-insert-file | |
206 (expand-file-name vc-name-assoc-file | |
207 (file-name-directory (vc-name file)))) | |
208 (vc-parse-buffer (concat name "\t:\t" file "\t\\(.+\\)") 1)))) | |
209 | |
210 (defun vc-sccs-merge (file first-version &optional second-version) | |
211 (error "Merging not implemented for SCCS")) | |
212 | |
213 (defun vc-sccs-check-headers () | |
214 "Check if the current file has any headers in it." | |
215 (save-excursion | |
216 (goto-char (point-min)) | |
217 (re-search-forward "%[A-Z]%" nil t))) | |
218 | |
219 (defun vc-sccs-steal-lock (file &optional rev) | |
220 "Steal the lock on the current workfile for FILE and revision REV." | |
221 (vc-do-command nil 0 "unget" (vc-name file) "-n" (if rev (concat "-r" rev))) | |
222 (vc-do-command nil 0 "get" (vc-name file) "-g" (if rev (concat "-r" rev)))) | |
223 | |
224 (defun vc-sccs-uncheck (file target) | |
225 "Undo the checkin of FILE's revision TARGET." | |
226 (vc-do-command nil 0 "rmdel" (vc-name file) (concat "-r" target))) | |
227 | |
228 (defun vc-sccs-revert (file) | |
229 "Revert FILE to the version it was based on." | |
230 (vc-do-command nil 0 "unget" (vc-name file)) | |
231 (vc-do-command nil 0 "get" (vc-name file)) | |
232 ;; Checking out explicit versions is not supported under SCCS, yet. | |
233 ;; We always "revert" to the latest version; therefore | |
234 ;; vc-workfile-version is cleared here so that it gets recomputed. | |
235 (vc-file-setprop file 'vc-workfile-version nil)) | |
236 | |
237 (defun vc-sccs-checkin (file rev comment) | |
238 "SCCS-specific version of `vc-backend-checkin'." | |
239 (let ((switches (if (stringp vc-checkin-switches) | |
240 (list vc-checkin-switches) | |
241 vc-checkin-switches))) | |
242 (apply 'vc-do-command nil 0 "delta" (vc-name file) | |
243 (if rev (concat "-r" rev)) | |
244 (concat "-y" comment) | |
245 switches) | |
246 (vc-file-setprop file 'vc-state 'up-to-date) | |
247 (vc-file-setprop file 'vc-workfile-version nil) | |
248 (if vc-keep-workfiles | |
249 (vc-do-command nil 0 "get" (vc-name file))))) | |
250 | |
251 (defun vc-sccs-latest-on-branch-p (file) | |
252 "Return t iff the current workfile version of FILE is the latest on | |
253 its branch." | |
254 ;; Always return t; we do not support previous versions in the workfile | |
255 ;; under SCCS. | |
256 t) | |
257 | |
258 (defun vc-sccs-logentry-check () | |
259 "Check that the log entry in the current buffer is acceptable for SCCS." | |
260 (when (>= (buffer-size) 512) | |
261 (goto-char 512) | |
262 (error "Log must be less than 512 characters; point is now at pos 512"))) | |
263 | |
264 (defun vc-sccs-diff (file &optional oldvers newvers) | |
265 "Get a difference report using SCCS between two versions of FILE." | |
266 (setq oldvers (vc-sccs-lookup-triple file oldvers)) | |
267 (setq newvers (vc-sccs-lookup-triple file newvers)) | |
268 (let* ((diff-switches-list (if (listp diff-switches) | |
269 diff-switches | |
270 (list diff-switches))) | |
271 (options (append (list "-q" | |
272 (and oldvers (concat "-r" oldvers)) | |
273 (and newvers (concat "-r" newvers))) | |
274 diff-switches-list))) | |
275 (apply 'vc-do-command t 1 "vcdiff" (vc-name file) options))) | |
276 | |
277 (defun vc-sccs-responsible-p (file) | |
278 "Return non-nil if SCCS thinks it would be responsible for registering FILE." | |
279 ;; TODO: check for all the patterns in vc-sccs-master-templates | |
280 (or (file-directory-p (expand-file-name "SCCS" (file-name-directory file))) | |
281 (stringp (vc-sccs-search-project-dir (or (file-name-directory file) "") | |
282 (file-name-nondirectory file))))) | |
283 | |
284 (defun vc-sccs-register (file &optional rev comment) | |
285 "Register FILE into the SCCS version-control system. | |
286 REV is the optional revision number for the file. COMMENT can be used | |
287 to provide an initial description of FILE. | |
288 | |
289 `vc-register-switches' and `vc-sccs-register-switches' are passed to | |
290 the SCCS command (in that order). | |
291 | |
292 Automatically retrieve a read-only version of the file with keywords | |
293 expanded if `vc-keep-workfiles' is non-nil, otherwise, delete the workfile." | |
294 (vc-file-clearprops file) | |
295 (let* ((switches (list | |
296 (if (stringp vc-register-switches) | |
297 (list vc-register-switches) | |
298 vc-register-switches) | |
299 (if (stringp vc-sccs-register-switches) | |
300 (list vc-sccs-register-switches) | |
301 vc-sccs-register-switches))) | |
302 (dirname (or (file-name-directory file) "")) | |
303 (basename (file-name-nondirectory file)) | |
304 (project-file (vc-sccs-search-project-dir dirname basename))) | |
305 (let ((vc-name | |
306 (or project-file | |
307 (format (car vc-sccs-master-templates) dirname basename)))|) | |
308 (apply 'vc-do-command nil 0 "admin" nil | |
309 (and rev (concat "-r" rev)) | |
310 "-fb" | |
311 (concat "-i" file) | |
312 (and comment (concat "-y" comment)) | |
313 vc-name | |
314 switches)) | |
315 (delete-file file) | |
316 (if vc-keep-workfiles | |
317 (vc-do-command nil 0 "get" (vc-name file))))) | |
318 | |
319 (defun vc-sccs-checkout (file &optional writable rev workfile) | |
320 "Retrieve a copy of a saved version of an SCCS controlled FILE into | |
321 a WORKFILE. WRITABLE non-nil means that the file should be writable. | |
322 REV is the revision to check out into WORKFILE." | |
323 (let ((filename (or workfile file)) | |
324 (file-buffer (get-file-buffer file)) | |
325 switches) | |
326 (message "Checking out %s..." filename) | |
327 (save-excursion | |
328 ;; Change buffers to get local value of vc-checkout-switches. | |
329 (if file-buffer (set-buffer file-buffer)) | |
330 (setq switches (if (stringp vc-checkout-switches) | |
331 (list vc-checkout-switches) | |
332 vc-checkout-switches)) | |
333 ;; Save this buffer's default-directory | |
334 ;; and use save-excursion to make sure it is restored | |
335 ;; in the same buffer it was saved in. | |
336 (let ((default-directory default-directory)) | |
337 (save-excursion | |
338 ;; Adjust the default-directory so that the check-out creates | |
339 ;; the file in the right place. | |
340 (setq default-directory (file-name-directory filename)) | |
341 | |
342 (and rev (string= rev "") (setq rev nil)) | |
343 (if workfile | |
344 ;; Some SCCS implementations allow checking out directly to a | |
345 ;; file using the -G option, but then some don't so use the | |
346 ;; least common denominator approach and use the -p option | |
347 ;; ala RCS. | |
348 (let ((vc-modes (logior (file-modes (vc-name file)) | |
349 (if writable 128 0))) | |
350 (failed t)) | |
351 (unwind-protect | |
352 (progn | |
353 (let ((coding-system-for-read 'no-conversion) | |
354 (coding-system-for-write 'no-conversion)) | |
355 (with-temp-file filename | |
356 (apply 'vc-do-command | |
357 (current-buffer) 0 "get" (vc-name file) | |
358 "-s" ;; suppress diagnostic output | |
359 (if writable "-e") | |
360 "-p" | |
361 (and rev | |
362 (concat "-r" | |
363 (vc-sccs-lookup-triple file rev))) | |
364 switches))) | |
365 (set-file-modes filename | |
366 (logior (file-modes (vc-name file)) | |
367 (if writable 128 0))) | |
368 (setq failed nil)) | |
369 (and failed (file-exists-p filename) | |
370 (delete-file filename)))) | |
371 (apply 'vc-do-command nil 0 "get" (vc-name file) | |
372 (if writable "-e") | |
373 (and rev (concat "-r" (vc-sccs-lookup-triple file rev))) | |
374 switches) | |
375 (vc-file-setprop file 'vc-workfile-version nil)) | |
376 (unless workfile | |
377 (if writable | |
378 (vc-file-setprop file 'vc-state 'edited)) | |
379 (vc-file-setprop file | |
380 'vc-checkout-time (nth 5 (file-attributes file)))) | |
381 (message "Checking out %s...done" filename)))))) | |
382 | |
383 (defun vc-sccs-update-changelog (files) | |
384 (error "Sorry, generating ChangeLog entries is not implemented for SCCS.")) | |
385 | |
386 (provide 'vc-sccs) | |
387 | |
388 ;;; vc-sccs.el ends here |