1 ;;; vc-sccs.el --- support for SCCS version-control
3 ;; Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 ;; 2001, 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc.
6 ;; Author: FSF (see vc.el for full credits)
7 ;; Maintainer: Andre Spiegel <spiegel@gnu.org>
9 ;; $Id: vc-sccs.el,v 1.25 2004/03/21 15:49:55 spiegel Exp $
11 ;; This file is part of GNU Emacs.
13 ;; GNU Emacs is free software; you can redistribute it and/or modify
14 ;; it under the terms of the GNU General Public License as published by
15 ;; the Free Software Foundation; either version 2, or (at your option)
18 ;; GNU Emacs is distributed in the hope that it will be useful,
19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21 ;; GNU General Public License for more details.
23 ;; You should have received a copy of the GNU General Public License
24 ;; along with GNU Emacs; see the file COPYING. If not, write to the
25 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
26 ;; Boston, MA 02110-1301, USA.
36 ;;; Customization options
39 (defcustom vc-sccs-register-switches nil
40 "*Extra switches for registering a file in SCCS.
41 A string or list of strings passed to the checkin program by
42 \\[vc-sccs-register]."
43 :type '(choice (const :tag "None" nil)
44 (string :tag "Argument String")
45 (repeat :tag "Argument List"
51 (defcustom vc-sccs-diff-switches nil
52 "*A string or list of strings specifying extra switches for `vcdiff',
53 the diff utility used for SCCS under VC."
54 :type '(choice (const :tag "None" nil)
55 (string :tag "Argument String")
56 (repeat :tag "Argument List"
62 (defcustom vc-sccs-header (or (cdr (assoc 'SCCS vc-header-alist)) '("%W%"))
63 "*Header keywords to be inserted by `vc-insert-headers'."
64 :type '(repeat string)
68 (defcustom vc-sccs-master-templates
69 '("%sSCCS/s.%s" "%ss.%s" vc-sccs-search-project-dir)
70 "*Where to look for SCCS master files.
71 For a description of possible values, see `vc-check-master-templates'."
72 :type '(choice (const :tag "Use standard SCCS file names"
73 ("%sSCCS/s.%s" "%ss.%s" vc-sccs-search-project-dir))
74 (repeat :tag "User-specified"
82 ;;; Internal variables
85 (defconst vc-sccs-name-assoc-file "VC-names")
89 ;;; State-querying functions
92 ;;; The autoload cookie below places vc-sccs-registered directly into
93 ;;; loaddefs.el, so that vc-sccs.el does not need to be loaded for
94 ;;; every file that is visited. The definition is repeated below
95 ;;; so that Help and etags can find it.
97 ;;;###autoload (defun vc-sccs-registered(f) (vc-default-registered 'SCCS f))
98 (defun vc-sccs-registered (f) (vc-default-registered 'SCCS f))
100 (defun vc-sccs-state (file)
101 "SCCS-specific function to compute the version control state."
103 (if (vc-insert-file (vc-sccs-lock-file file))
104 (let* ((locks (vc-sccs-parse-locks))
105 (workfile-version (vc-workfile-version file))
106 (locking-user (cdr (assoc workfile-version locks))))
107 (if (not locking-user)
108 (if (vc-workfile-unchanged-p file)
111 (if (string= locking-user (vc-user-login-name file))
116 (defun vc-sccs-state-heuristic (file)
117 "SCCS-specific state heuristic."
118 (if (not (vc-mistrust-permissions file))
119 ;; This implementation assumes that any file which is under version
120 ;; control and has -rw-r--r-- is locked by its owner. This is true
121 ;; for both RCS and SCCS, which keep unlocked files at -r--r--r--.
122 ;; We have to be careful not to exclude files with execute bits on;
123 ;; scripts can be under version control too. Also, we must ignore the
124 ;; group-read and other-read bits, since paranoid users turn them off.
125 ;; XEmacs change: no 2nd arg to `file-attributes'
126 (let* ((attributes (file-attributes file))
127 (owner-uid (nth 2 attributes))
128 (owner-name (or (user-login-name owner-uid)
129 (number-to-string owner-uid)))
130 (permissions (nth 8 attributes)))
131 (if (string-match ".r-..-..-." permissions)
133 (if (string-match ".rw..-..-." permissions)
134 (if (file-ownership-preserved-p file)
137 ;; Strange permissions.
138 ;; Fall through to real state computation.
139 (vc-sccs-state file))))
140 (vc-sccs-state file)))
142 (defun vc-sccs-workfile-version (file)
143 "SCCS-specific version of `vc-workfile-version'."
145 ;; The workfile version is always the latest version number.
146 ;; To find this number, search the entire delta table,
147 ;; rather than just the first entry, because the
148 ;; first entry might be a deleted ("R") version.
149 (vc-insert-file (vc-name file) "^\001e\n\001[^s]")
150 (vc-parse-buffer "^\001d D \\([^ ]+\\)" 1)))
152 (defun vc-sccs-checkout-model (file)
153 "SCCS-specific version of `vc-checkout-model'."
156 (defun vc-sccs-workfile-unchanged-p (file)
157 "SCCS-specific implementation of `vc-workfile-unchanged-p'."
158 (zerop (apply 'vc-do-command nil 1 "vcdiff" (vc-name file)
160 (concat "-r" (vc-workfile-version file))))))
164 ;;; State-changing functions
167 (defun vc-sccs-register (file &optional rev comment)
168 "Register FILE into the SCCS version-control system.
169 REV is the optional revision number for the file. COMMENT can be used
170 to provide an initial description of FILE.
172 `vc-register-switches' and `vc-sccs-register-switches' are passed to
173 the SCCS command (in that order).
175 Automatically retrieve a read-only version of the file with keywords
176 expanded if `vc-keep-workfiles' is non-nil, otherwise, delete the workfile."
177 (let* ((dirname (or (file-name-directory file) ""))
178 (basename (file-name-nondirectory file))
179 (project-file (vc-sccs-search-project-dir dirname basename)))
182 (format (car vc-sccs-master-templates) dirname basename))))
183 (apply 'vc-do-command nil 0 "admin" vc-name
184 (and rev (concat "-r" rev))
186 (concat "-i" (file-relative-name file))
187 (and comment (concat "-y" comment))
188 (vc-switches 'SCCS 'register)))
190 (if vc-keep-workfiles
191 (vc-do-command nil 0 "get" (vc-name file)))))
193 (defun vc-sccs-responsible-p (file)
194 "Return non-nil if SCCS thinks it would be responsible for registering FILE."
195 ;; TODO: check for all the patterns in vc-sccs-master-templates
196 (or (file-directory-p (expand-file-name "SCCS" (file-name-directory file)))
197 (stringp (vc-sccs-search-project-dir (or (file-name-directory file) "")
198 (file-name-nondirectory file)))))
200 (defun vc-sccs-checkin (file rev comment)
201 "SCCS-specific version of `vc-backend-checkin'."
202 (apply 'vc-do-command nil 0 "delta" (vc-name file)
203 (if rev (concat "-r" rev))
204 (concat "-y" comment)
205 (vc-switches 'SCCS 'checkin))
206 (if vc-keep-workfiles
207 (vc-do-command nil 0 "get" (vc-name file))))
209 (defun vc-sccs-find-version (file rev buffer)
210 (apply 'vc-do-command
211 buffer 0 "get" (vc-name file)
212 "-s" ;; suppress diagnostic output
216 (vc-sccs-lookup-triple file rev)))
217 (vc-switches 'SCCS 'checkout)))
219 (defun vc-sccs-checkout (file &optional editable rev)
220 "Retrieve a copy of a saved version of SCCS controlled FILE.
221 EDITABLE non-nil means that the file should be writable and
222 locked. REV is the revision to check out."
223 (let ((file-buffer (get-file-buffer file))
225 (message "Checking out %s..." file)
227 ;; Change buffers to get local value of vc-checkout-switches.
228 (if file-buffer (set-buffer file-buffer))
229 (setq switches (vc-switches 'SCCS 'checkout))
230 ;; Save this buffer's default-directory
231 ;; and use save-excursion to make sure it is restored
232 ;; in the same buffer it was saved in.
233 (let ((default-directory default-directory))
235 ;; Adjust the default-directory so that the check-out creates
236 ;; the file in the right place.
237 (setq default-directory (file-name-directory file))
239 (and rev (or (string= rev "")
242 (apply 'vc-do-command nil 0 "get" (vc-name file)
244 (and rev (concat "-r" (vc-sccs-lookup-triple file rev)))
246 (message "Checking out %s...done" file)))
248 (defun vc-sccs-revert (file &optional contents-done)
249 "Revert FILE to the version it was based on."
250 (vc-do-command nil 0 "unget" (vc-name file))
251 (vc-do-command nil 0 "get" (vc-name file))
252 ;; Checking out explicit versions is not supported under SCCS, yet.
253 ;; We always "revert" to the latest version; therefore
254 ;; vc-workfile-version is cleared here so that it gets recomputed.
255 (vc-file-setprop file 'vc-workfile-version nil))
257 (defun vc-sccs-cancel-version (file editable)
258 "Undo the most recent checkin of FILE.
259 EDITABLE non-nil means previous version should be locked."
260 (vc-do-command nil 0 "rmdel"
262 (concat "-r" (vc-workfile-version file)))
263 (vc-do-command nil 0 "get"
267 (defun vc-sccs-steal-lock (file &optional rev)
268 "Steal the lock on the current workfile for FILE and revision REV."
269 (vc-do-command nil 0 "unget" (vc-name file) "-n" (if rev (concat "-r" rev)))
270 (vc-do-command nil 0 "get" (vc-name file) "-g" (if rev (concat "-r" rev))))
274 ;;; History functions
277 (defun vc-sccs-print-log (file &optional buffer)
278 "Get change log associated with FILE."
279 (vc-do-command buffer 0 "prs" (vc-name file)))
281 (defun vc-sccs-logentry-check ()
282 "Check that the log entry in the current buffer is acceptable for SCCS."
283 (when (>= (buffer-size) 512)
285 (error "Log must be less than 512 characters; point is now at pos 512")))
287 (defun vc-sccs-diff (file &optional oldvers newvers buffer)
288 "Get a difference report using SCCS between two versions of FILE."
289 (setq oldvers (vc-sccs-lookup-triple file oldvers))
290 (setq newvers (vc-sccs-lookup-triple file newvers))
291 (apply 'vc-do-command (or buffer "*vc-diff*") 1 "vcdiff" (vc-name file)
293 (and oldvers (concat "-r" oldvers))
294 (and newvers (concat "-r" newvers)))
295 (vc-switches 'SCCS 'diff))))
302 (defun vc-sccs-assign-name (file name)
303 "Assign to FILE's latest version a given NAME."
304 (vc-sccs-add-triple name file (vc-workfile-version file)))
311 (defun vc-sccs-check-headers ()
312 "Check if the current file has any headers in it."
314 (goto-char (point-min))
315 (re-search-forward "%[A-Z]%" nil t)))
317 (defun vc-sccs-rename-file (old new)
318 ;; Move the master file (using vc-rcs-master-templates).
319 (vc-rename-master (vc-name old) new vc-sccs-master-templates)
320 ;; Update the snapshot file.
323 (expand-file-name vc-sccs-name-assoc-file
324 (file-name-directory (vc-name old))))
325 (goto-char (point-min))
326 ;; (replace-regexp (concat ":" (regexp-quote old) "$") (concat ":" new))
327 (while (re-search-forward (concat ":" (regexp-quote old) "$") nil t)
328 (replace-match (concat ":" new) nil nil))
330 (kill-buffer (current-buffer))))
334 ;;; Internal functions
337 ;; This function is wrapped with `progn' so that the autoload cookie
338 ;; copies the whole function itself into loaddefs.el rather than just placing
339 ;; a (autoload 'vc-sccs-search-project-dir "vc-sccs") which would not
340 ;; help us avoid loading vc-sccs.
342 (progn (defun vc-sccs-search-project-dir (dirname basename)
343 "Return the name of a master file in the SCCS project directory.
344 Does not check whether the file exists but returns nil if it does not
345 find any project directory."
346 (let ((project-dir (getenv "PROJECTDIR")) dirs dir)
348 (if (file-name-absolute-p project-dir)
349 (setq dirs '("SCCS" ""))
350 (setq dirs '("src/SCCS" "src" "source/SCCS" "source"))
351 (setq project-dir (expand-file-name (concat "~" project-dir))))
352 (while (and (not dir) dirs)
353 (setq dir (expand-file-name (car dirs) project-dir))
354 (unless (file-directory-p dir)
356 (setq dirs (cdr dirs))))
357 (and dir (expand-file-name (concat "s." basename) dir))))))
359 (defun vc-sccs-lock-file (file)
360 "Generate lock file name corresponding to FILE."
361 (let ((master (vc-name file)))
364 (string-match "\\(.*/\\)\\(s\\.\\)\\(.*\\)" master)
365 ;; XEmacs change: don't use replace-match here; our API differs from GNU
366 (concat (match-string 1 master) "p." (match-string 3 master)))))
368 (defun vc-sccs-parse-locks ()
369 "Parse SCCS locks in current buffer.
370 The result is a list of the form ((VERSION . USER) (VERSION . USER) ...)."
372 (goto-char (point-min))
373 (while (re-search-forward "^\\([0-9.]+\\) [0-9.]+ \\([^ ]+\\) .*\n?"
376 (cons (cons (match-string 1) (match-string 2)) master-locks)))
377 ;; FIXME: is it really necessary to reverse ?
378 (nreverse master-locks)))
380 (defun vc-sccs-add-triple (name file rev)
383 (expand-file-name vc-sccs-name-assoc-file
384 (file-name-directory (vc-name file))))
385 (goto-char (point-max))
386 (insert name "\t:\t" file "\t" rev "\n")
388 (kill-buffer (current-buffer))))
390 (defun vc-sccs-lookup-triple (file name)
391 "Return the numeric version corresponding to a named snapshot of FILE.
392 If NAME is nil or a version number string it's just passed through."
394 (let ((firstchar (aref name 0)))
395 (and (>= firstchar ?0) (<= firstchar ?9))))
399 (expand-file-name vc-sccs-name-assoc-file
400 (file-name-directory (vc-name file))))
401 (vc-parse-buffer (concat name "\t:\t" file "\t\\(.+\\)") 1))))
405 ;; arch-tag: d751dee3-d7b3-47e1-95e3-7ae98c052041
406 ;;; vc-sccs.el ends here