Don't use -subsystem=console link option, it is the default.
[bpt/emacs.git] / lisp / vc / vc-sccs.el
CommitLineData
7a004b71
GM
1;;; vc-sccs.el --- support for SCCS version-control
2
ab422c4d 3;; Copyright (C) 1992-2013 Free Software Foundation, Inc.
7a004b71
GM
4
5;; Author: FSF (see vc.el for full credits)
6;; Maintainer: Andre Spiegel <spiegel@gnu.org>
bd78fa1d 7;; Package: vc
7a004b71 8
7a004b71
GM
9;; This file is part of GNU Emacs.
10
eb3fa2cf 11;; GNU Emacs is free software: you can redistribute it and/or modify
7a004b71 12;; it under the terms of the GNU General Public License as published by
eb3fa2cf
GM
13;; the Free Software Foundation, either version 3 of the License, or
14;; (at your option) any later version.
7a004b71
GM
15
16;; GNU Emacs is distributed in the hope that it will be useful,
17;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19;; GNU General Public License for more details.
20
21;; You should have received a copy of the GNU General Public License
eb3fa2cf 22;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
7a004b71
GM
23
24;;; Commentary:
25
26;;; Code:
27
f1180544 28(eval-when-compile
a1e9f194
AS
29 (require 'vc))
30
f1180544 31;;;
8f98485f
AS
32;;; Customization options
33;;;
34
14b11401 35;; ;; Maybe a better solution is to not use "get" but "sccs get".
7a58f64d
GM
36;; ;; Note for GNU CSSC, you can parse sccs -V to get the libexec path.
37;; (defcustom vc-sccs-path
38;; (prune-directory-list '("/usr/ccs/bin" "/usr/sccs" "/usr/lib/sccs"
39;; "/usr/libexec/sccs"))
40;; "List of extra directories to search for SCCS commands."
41;; :type '(repeat directory)
42;; :group 'vc)
14b11401 43
67b0de11
CY
44(defgroup vc-sccs nil
45 "VC SCCS backend."
46 :version "24.1"
47 :group 'vc)
48
7a004b71 49(defcustom vc-sccs-register-switches nil
12fcd25a 50 "Switches for registering a file in SCCS.
a7cafade 51A string or list of strings passed to the checkin program by
12fcd25a
GM
52\\[vc-register]. If nil, use the value of `vc-register-switches'.
53If t, use no switches."
54 :type '(choice (const :tag "Unspecified" nil)
55 (const :tag "None" t)
7a004b71 56 (string :tag "Argument String")
12fcd25a 57 (repeat :tag "Argument List" :value ("") string))
a7cafade 58 :version "21.1"
67b0de11 59 :group 'vc-sccs)
7a004b71 60
a1e9f194 61(defcustom vc-sccs-diff-switches nil
3edf7a64
GM
62 "String or list of strings specifying switches for SCCS diff under VC.
63If nil, use the value of `vc-diff-switches'. If t, use no switches."
64 :type '(choice (const :tag "Unspecified" nil)
65 (const :tag "None" t)
a1e9f194 66 (string :tag "Argument String")
3edf7a64 67 (repeat :tag "Argument List" :value ("") string))
a1e9f194 68 :version "21.1"
67b0de11 69 :group 'vc-sccs)
a1e9f194 70
67141a37 71(defcustom vc-sccs-header '("%W%")
9201cc28 72 "Header keywords to be inserted by `vc-insert-headers'."
8b7c8991 73 :type '(repeat string)
67141a37 74 :version "24.1" ; no longer consult the obsolete vc-header-alist
67b0de11 75 :group 'vc-sccs)
7a004b71 76
91740b40
GM
77;; This needs to be autoloaded because vc-sccs-registered uses it (via
78;; vc-default-registered), and vc-hooks needs to be able to check
79;; for a registered backend without loading every backend.
d2a54f13 80;;;###autoload
7a004b71 81(defcustom vc-sccs-master-templates
d2a54f13 82 (purecopy '("%sSCCS/s.%s" "%ss.%s" vc-sccs-search-project-dir))
9201cc28 83 "Where to look for SCCS master files.
7a004b71
GM
84For a description of possible values, see `vc-check-master-templates'."
85 :type '(choice (const :tag "Use standard SCCS file names"
86 ("%sSCCS/s.%s" "%ss.%s" vc-sccs-search-project-dir))
87 (repeat :tag "User-specified"
88 (choice string
89 function)))
a7cafade 90 :version "21.1"
67b0de11 91 :group 'vc-sccs)
7a004b71 92
8f98485f
AS
93\f
94;;;
95;;; Internal variables
96;;;
97
099bd78a
SM
98(defconst vc-sccs-name-assoc-file "VC-names")
99
8f98485f 100\f
8cdd17b4
ER
101;;; Properties of the backend
102
14b11401 103(defun vc-sccs-revision-granularity () 'file)
70e2f6c7 104(defun vc-sccs-checkout-model (files) 'locking)
8cdd17b4 105
8f98485f
AS
106;;;
107;;; State-querying functions
108;;;
109
630d468c
GM
110;; The autoload cookie below places vc-sccs-registered directly into
111;; loaddefs.el, so that vc-sccs.el does not need to be loaded for
7bd302eb
GM
112;; every file that is visited.
113;;;###autoload
114(progn
115(defun vc-sccs-registered (f) (vc-default-registered 'SCCS f)))
7a004b71
GM
116
117(defun vc-sccs-state (file)
118 "SCCS-specific function to compute the version control state."
3702367b
ER
119 (if (not (vc-sccs-registered file))
120 'unregistered
121 (with-temp-buffer
122 (if (vc-insert-file (vc-sccs-lock-file file))
123 (let* ((locks (vc-sccs-parse-locks))
124 (working-revision (vc-working-revision file))
125 (locking-user (cdr (assoc working-revision locks))))
126 (if (not locking-user)
127 (if (vc-workfile-unchanged-p file)
128 'up-to-date
129 'unlocked-changes)
130 (if (string= locking-user (vc-user-login-name file))
131 'edited
132 locking-user)))
133 'up-to-date))))
7a004b71
GM
134
135(defun vc-sccs-state-heuristic (file)
136 "SCCS-specific state heuristic."
137 (if (not (vc-mistrust-permissions file))
138 ;; This implementation assumes that any file which is under version
139 ;; control and has -rw-r--r-- is locked by its owner. This is true
140 ;; for both RCS and SCCS, which keep unlocked files at -r--r--r--.
141 ;; We have to be careful not to exclude files with execute bits on;
142 ;; scripts can be under version control too. Also, we must ignore the
143 ;; group-read and other-read bits, since paranoid users turn them off.
bbd88348
AS
144 (let* ((attributes (file-attributes file 'string))
145 (owner-name (nth 2 attributes))
7a004b71
GM
146 (permissions (nth 8 attributes)))
147 (if (string-match ".r-..-..-." permissions)
148 'up-to-date
149 (if (string-match ".rw..-..-." permissions)
150 (if (file-ownership-preserved-p file)
151 'edited
bbd88348 152 owner-name)
8bfde4be
AS
153 ;; Strange permissions.
154 ;; Fall through to real state computation.
155 (vc-sccs-state file))))
156 (vc-sccs-state file)))
7a004b71 157
c1b51374 158(defun vc-sccs-dir-status (dir update-function)
4b1a01b3
DN
159 ;; FIXME: this function should be rewritten, using `vc-expand-dirs'
160 ;; is not TRTD because it returns files from multiple backends.
161 ;; It should also return 'unregistered files.
162
163 ;; Doing lots of individual VC-state calls is painful, but
5a9de6d0 164 ;; there is no better option in SCCS-land.
90e9ca17
DN
165 (let ((flist (vc-expand-dirs (list dir)))
166 (result nil))
167 (dolist (file flist)
168 (let ((state (vc-state file))
169 (frel (file-relative-name file)))
4b1a01b3
DN
170 (when (and (eq (vc-backend file) 'SCCS)
171 (not (eq state 'up-to-date)))
172 (push (list frel state) result))))
c1b51374 173 (funcall update-function result)))
90e9ca17 174
ac3f4c6f
ER
175(defun vc-sccs-working-revision (file)
176 "SCCS-specific version of `vc-working-revision'."
7a004b71 177 (with-temp-buffer
5b5afd50 178 ;; The working revision is always the latest revision number.
8bfde4be
AS
179 ;; To find this number, search the entire delta table,
180 ;; rather than just the first entry, because the
5b5afd50 181 ;; first entry might be a deleted ("R") revision.
8bfde4be 182 (vc-insert-file (vc-name file) "^\001e\n\001[^s]")
7a004b71
GM
183 (vc-parse-buffer "^\001d D \\([^ ]+\\)" 1)))
184
7a58f64d
GM
185;; Cf vc-sccs-find-revision.
186(defun vc-sccs-write-revision (file outfile &optional rev)
187 "Write the SCCS version of input file FILE to output file OUTFILE.
188Optional string REV is a revision."
189 (with-temp-buffer
190 (apply 'vc-sccs-do-command t 0 "get" (vc-name file)
191 (append '("-s" "-p" "-k") ; -k: no keyword expansion
192 (if rev (list (concat "-r" rev)))))
193 (write-region nil nil outfile nil 'silent)))
194
7a004b71 195(defun vc-sccs-workfile-unchanged-p (file)
fa63cb6d 196 "SCCS-specific implementation of `vc-workfile-unchanged-p'."
08f9f738
GM
197 (let ((tempfile (make-temp-file "vc-sccs")))
198 (unwind-protect
199 (progn
7a58f64d 200 (vc-sccs-write-revision file tempfile (vc-working-revision file))
08f9f738
GM
201 (zerop (vc-do-command "*vc*" 1 "cmp" file tempfile)))
202 (delete-file tempfile))))
7a004b71 203
7a004b71 204\f
8f98485f
AS
205;;;
206;;; State-changing functions
207;;;
7a004b71 208
14b11401
SM
209(defun vc-sccs-do-command (buffer okstatus command file-or-list &rest flags)
210 ;; (let ((load-path (append vc-sccs-path load-path)))
211 ;; (apply 'vc-do-command buffer okstatus command file-or-list flags))
2888a97e 212 (apply 'vc-do-command (or buffer "*vc*") okstatus "sccs" file-or-list command flags))
14b11401 213
8cdd17b4
ER
214(defun vc-sccs-create-repo ()
215 "Create a new SCCS repository."
216 ;; SCCS is totally file-oriented, so all we have to do is make the directory
217 (make-directory "SCCS"))
218
219(defun vc-sccs-register (files &optional rev comment)
220 "Register FILES into the SCCS version-control system.
7a004b71 221REV is the optional revision number for the file. COMMENT can be used
8cdd17b4 222to provide an initial description of FILES.
12fcd25a
GM
223Passes either `vc-sccs-register-switches' or `vc-register-switches'
224to the SCCS command.
7a004b71 225
8cdd17b4 226Automatically retrieve a read-only version of the files with keywords
7a004b71 227expanded if `vc-keep-workfiles' is non-nil, otherwise, delete the workfile."
8cdd17b4 228 (dolist (file files)
dc0f87c9 229 (let* ((dirname (or (file-name-directory file) ""))
7a004b71
GM
230 (basename (file-name-nondirectory file))
231 (project-file (vc-sccs-search-project-dir dirname basename)))
232 (let ((vc-name
233 (or project-file
dc0f87c9 234 (format (car vc-sccs-master-templates) dirname basename))))
14b11401 235 (apply 'vc-sccs-do-command nil 0 "admin" vc-name
8cdd17b4 236 (and rev (not (string= rev "")) (concat "-r" rev))
7a004b71 237 "-fb"
0cccd8ff 238 (concat "-i" (file-relative-name file))
7a004b71 239 (and comment (concat "-y" comment))
dc0f87c9 240 (vc-switches 'SCCS 'register)))
7a004b71
GM
241 (delete-file file)
242 (if vc-keep-workfiles
14b11401 243 (vc-sccs-do-command nil 0 "get" (vc-name file))))))
7a004b71 244
8f98485f
AS
245(defun vc-sccs-responsible-p (file)
246 "Return non-nil if SCCS thinks it would be responsible for registering FILE."
247 ;; TODO: check for all the patterns in vc-sccs-master-templates
248 (or (file-directory-p (expand-file-name "SCCS" (file-name-directory file)))
249 (stringp (vc-sccs-search-project-dir (or (file-name-directory file) "")
250 (file-name-nondirectory file)))))
251
4624de78 252(defun vc-sccs-checkin (files rev comment)
8f98485f 253 "SCCS-specific version of `vc-backend-checkin'."
e7290559 254 (dolist (file (vc-expand-dirs files))
14b11401 255 (apply 'vc-sccs-do-command nil 0 "delta" (vc-name file)
8cdd17b4
ER
256 (if rev (concat "-r" rev))
257 (concat "-y" comment)
258 (vc-switches 'SCCS 'checkin))
259 (if vc-keep-workfiles
14b11401 260 (vc-sccs-do-command nil 0 "get" (vc-name file)))))
8f98485f 261
ac3f4c6f 262(defun vc-sccs-find-revision (file rev buffer)
14b11401 263 (apply 'vc-sccs-do-command
52876673
SM
264 buffer 0 "get" (vc-name file)
265 "-s" ;; suppress diagnostic output
266 "-p"
267 (and rev
268 (concat "-r"
269 (vc-sccs-lookup-triple file rev)))
dc0f87c9 270 (vc-switches 'SCCS 'checkout)))
52876673
SM
271
272(defun vc-sccs-checkout (file &optional editable rev)
5b5afd50 273 "Retrieve a copy of a saved revision of SCCS controlled FILE.
e7290559 274If FILE is a directory, all version-controlled files beneath are checked out.
1862f9ef 275EDITABLE non-nil means that the file should be writable and
52876673 276locked. REV is the revision to check out."
a2a413ad 277 (if (file-directory-p file)
e7290559
ER
278 (mapc 'vc-sccs-checkout (vc-expand-dirs (list file)))
279 (let ((file-buffer (get-file-buffer file))
280 switches)
281 (message "Checking out %s..." file)
282 (save-excursion
283 ;; Change buffers to get local value of vc-checkout-switches.
284 (if file-buffer (set-buffer file-buffer))
285 (setq switches (vc-switches 'SCCS 'checkout))
286 ;; Save this buffer's default-directory
287 ;; and use save-excursion to make sure it is restored
288 ;; in the same buffer it was saved in.
289 (let ((default-directory default-directory))
290 (save-excursion
291 ;; Adjust the default-directory so that the check-out creates
292 ;; the file in the right place.
293 (setq default-directory (file-name-directory file))
294
295 (and rev (or (string= rev "")
296 (not (stringp rev)))
297 (setq rev nil))
298 (apply 'vc-sccs-do-command nil 0 "get" (vc-name file)
299 (if editable "-e")
300 (and rev (concat "-r" (vc-sccs-lookup-triple file rev)))
301 switches))))
302 (message "Checking out %s...done" file))))
7a004b71 303
5b5afd50 304(defun vc-sccs-rollback (files)
e7290559
ER
305 "Roll back, undoing the most recent checkins of FILES. Directories
306are expanded to all version-controlled subfiles."
307 (setq files (vc-expand-dirs files))
8cdd17b4 308 (if (not files)
5a0c3f56 309 (error "SCCS backend doesn't support directory-level rollback"))
8cdd17b4 310 (dolist (file files)
ac3f4c6f 311 (let ((discard (vc-working-revision file)))
a2a413ad 312 (if (null (yes-or-no-p (format "Remove version %s from %s history? "
8cdd17b4
ER
313 discard file)))
314 (error "Aborted"))
315 (message "Removing revision %s from %s..." discard file)
14b11401
SM
316 (vc-sccs-do-command nil 0 "rmdel"
317 (vc-name file) (concat "-r" discard))
318 (vc-sccs-do-command nil 0 "get" (vc-name file) nil))))
8cdd17b4 319
99739bbf 320(defun vc-sccs-revert (file &optional contents-done)
e7290559
ER
321 "Revert FILE to the version it was based on. If FILE is a directory,
322revert all subfiles."
a2a413ad 323 (if (file-directory-p file)
e7290559
ER
324 (mapc 'vc-sccs-revert (vc-expand-dirs (list file)))
325 (vc-sccs-do-command nil 0 "unget" (vc-name file))
326 (vc-sccs-do-command nil 0 "get" (vc-name file))
327 ;; Checking out explicit revisions is not supported under SCCS, yet.
328 ;; We always "revert" to the latest revision; therefore
329 ;; vc-working-revision is cleared here so that it gets recomputed.
330 (vc-file-setprop file 'vc-working-revision nil)))
8f98485f 331
8f98485f
AS
332(defun vc-sccs-steal-lock (file &optional rev)
333 "Steal the lock on the current workfile for FILE and revision REV."
a2a413ad 334 (if (file-directory-p file)
e7290559
ER
335 (mapc 'vc-sccs-steal-lock (vc-expand-dirs (list file)))
336 (vc-sccs-do-command nil 0 "unget"
337 (vc-name file) "-n" (if rev (concat "-r" rev)))
338 (vc-sccs-do-command nil 0 "get"
339 (vc-name file) "-g" (if rev (concat "-r" rev)))))
8f98485f 340
9b64a7f0
ER
341(defun vc-sccs-modify-change-comment (files rev comment)
342 "Modify (actually, append to) the change comments for FILES on a specified REV."
e7290559 343 (dolist (file (vc-expand-dirs files))
a2a413ad 344 (vc-sccs-do-command nil 0 "cdc" (vc-name file)
14b11401 345 (concat "-y" comment) (concat "-r" rev))))
9b64a7f0 346
8f98485f
AS
347\f
348;;;
349;;; History functions
350;;;
351
662c5698 352(defun vc-sccs-print-log (files buffer &optional shortlog start-revision-ignored limit)
8cdd17b4 353 "Get change log associated with FILES."
e7290559 354 (setq files (vc-expand-dirs files))
48b27575
DN
355 (vc-sccs-do-command buffer 0 "prs" (mapcar 'vc-name files))
356 (when limit 'limit-unsupported))
8cdd17b4 357
7a58f64d 358;; FIXME use sccsdiff if present?
8cdd17b4
ER
359(defun vc-sccs-diff (files &optional oldvers newvers buffer)
360 "Get a difference report using SCCS between two filesets."
e7290559 361 (setq files (vc-expand-dirs files))
e46e905a
GM
362 (setq oldvers (vc-sccs-lookup-triple (car files) oldvers))
363 (setq newvers (vc-sccs-lookup-triple (car files) newvers))
7a58f64d
GM
364 (or buffer (setq buffer "*vc-diff*"))
365 ;; We have to reimplement pieces of vc-do-command, because
366 ;; we want to run multiple external commands, and only do the setup
367 ;; and exit pieces once.
368 (save-current-buffer
369 (unless (or (eq buffer t)
370 (and (stringp buffer) (string= (buffer-name) buffer))
371 (eq buffer (current-buffer)))
372 (vc-setup-buffer buffer))
373 (let* ((fake-flags (append (vc-switches 'SCCS 'diff)
374 (if oldvers (list (concat " -r" oldvers)))
375 (if newvers (list (concat " -r" newvers)))))
376 (fake-command
377 (format "diff%s %s"
378 (if fake-flags
379 (concat " " (mapconcat 'identity fake-flags " "))
380 "")
381 (vc-delistify files)))
382 (status 0)
383 (oldproc (get-buffer-process (current-buffer))))
384 (when vc-command-messages
385 (message "Running %s in foreground..." fake-command))
386 (if oldproc (delete-process oldproc))
387 (dolist (file files)
388 (let ((oldfile (make-temp-file "vc-sccs"))
389 newfile)
390 (unwind-protect
391 (progn
392 (vc-sccs-write-revision file oldfile oldvers)
393 (if newvers
394 (vc-sccs-write-revision file (setq newfile
395 (make-temp-file "vc-sccs"))
396 newvers))
397 (let* ((inhibit-read-only t)
398 (buffer-undo-list t)
399 (process-environment
400 (cons "LC_MESSAGES=C" process-environment))
401 (w32-quote-process-args t)
402 (this-status
403 (apply 'process-file "diff" nil t nil
404 (append (vc-switches 'SCCS 'diff)
405 (list oldfile
406 (or newfile
407 (file-relative-name file)))))))
408 (or (integerp this-status) (setq status 'error))
409 (and (integerp status)
410 (> this-status status)
411 (setq status this-status))))
412 (delete-file oldfile)
413 (if newfile (delete-file newfile)))))
414 (when (or (not (integerp status)) (> status 1))
415 (unless (eq ?\s (aref (buffer-name (current-buffer)) 0))
416 (pop-to-buffer (current-buffer))
417 (goto-char (point-min))
418 (shrink-window-if-larger-than-buffer))
419 (error "Running %s...FAILED (%s)" fake-command
420 (if (integerp status) (format "status %d" status) status)))
421 (when vc-command-messages
422 (message "Running %s...OK = %d" fake-command status))
423 ;; Should we pretend we ran sccsdiff instead?
424 ;; This might not actually be a valid diff command.
425 (run-hook-with-args 'vc-post-command-functions "diff" files fake-flags)
426 status)))
8f98485f
AS
427
428\f
429;;;
370fded4
ER
430;;; Tag system. SCCS doesn't have tags, so we simulate them by maintaining
431;;; our own set of name-to-revision mappings.
8f98485f
AS
432;;;
433
70df4bbe 434(defun vc-sccs-create-tag (dir name branchp)
370fded4 435 (when branchp
70df4bbe 436 (error "SCCS backend does not support module branches"))
370fded4
ER
437 (let ((result (vc-tag-precondition dir)))
438 (if (stringp result)
439 (error "File %s is not up-to-date" result)
440 (vc-file-tree-walk
441 dir
442 (lambda (f)
443 (vc-sccs-add-triple name f (vc-working-revision f)))))))
8f98485f
AS
444
445\f
446;;;
447;;; Miscellaneous
448;;;
449
3b64d86b
DN
450(defun vc-sccs-previous-revision (file rev)
451 (vc-call-backend 'RCS 'previous-revision file rev))
452
453(defun vc-sccs-next-revision (file rev)
454 (vc-call-backend 'RCS 'next-revision file rev))
455
8f98485f
AS
456(defun vc-sccs-check-headers ()
457 "Check if the current file has any headers in it."
458 (save-excursion
459 (goto-char (point-min))
460 (re-search-forward "%[A-Z]%" nil t)))
461
462(defun vc-sccs-rename-file (old new)
463 ;; Move the master file (using vc-rcs-master-templates).
464 (vc-rename-master (vc-name old) new vc-sccs-master-templates)
370fded4 465 ;; Update the tag file.
8f98485f
AS
466 (with-current-buffer
467 (find-file-noselect
468 (expand-file-name vc-sccs-name-assoc-file
469 (file-name-directory (vc-name old))))
470 (goto-char (point-min))
471 ;; (replace-regexp (concat ":" (regexp-quote old) "$") (concat ":" new))
472 (while (re-search-forward (concat ":" (regexp-quote old) "$") nil t)
473 (replace-match (concat ":" new) nil nil))
474 (basic-save-buffer)
475 (kill-buffer (current-buffer))))
476
77bf3f54
DN
477(defun vc-sccs-find-file-hook ()
478 ;; If the file is locked by some other user, make
479 ;; the buffer read-only. Like this, even root
480 ;; cannot modify a file that someone else has locked.
d56fdcd2
DN
481 (and (stringp (vc-state buffer-file-name 'SCCS))
482 (setq buffer-read-only t)))
77bf3f54 483
8f98485f
AS
484\f
485;;;
486;;; Internal functions
487;;;
488
489;; This function is wrapped with `progn' so that the autoload cookie
490;; copies the whole function itself into loaddefs.el rather than just placing
491;; a (autoload 'vc-sccs-search-project-dir "vc-sccs") which would not
492;; help us avoid loading vc-sccs.
493;;;###autoload
494(progn (defun vc-sccs-search-project-dir (dirname basename)
495 "Return the name of a master file in the SCCS project directory.
496Does not check whether the file exists but returns nil if it does not
497find any project directory."
498 (let ((project-dir (getenv "PROJECTDIR")) dirs dir)
499 (when project-dir
500 (if (file-name-absolute-p project-dir)
501 (setq dirs '("SCCS" ""))
502 (setq dirs '("src/SCCS" "src" "source/SCCS" "source"))
503 (setq project-dir (expand-file-name (concat "~" project-dir))))
504 (while (and (not dir) dirs)
505 (setq dir (expand-file-name (car dirs) project-dir))
506 (unless (file-directory-p dir)
507 (setq dir nil)
508 (setq dirs (cdr dirs))))
509 (and dir (expand-file-name (concat "s." basename) dir))))))
510
511(defun vc-sccs-lock-file (file)
512 "Generate lock file name corresponding to FILE."
513 (let ((master (vc-name file)))
514 (and
515 master
516 (string-match "\\(.*/\\)\\(s\\.\\)\\(.*\\)" master)
517 (replace-match "p." t t master 2))))
518
519(defun vc-sccs-parse-locks ()
520 "Parse SCCS locks in current buffer.
5b5afd50 521The result is a list of the form ((REVISION . USER) (REVISION . USER) ...)."
8f98485f
AS
522 (let (master-locks)
523 (goto-char (point-min))
524 (while (re-search-forward "^\\([0-9.]+\\) [0-9.]+ \\([^ ]+\\) .*\n?"
525 nil t)
526 (setq master-locks
527 (cons (cons (match-string 1) (match-string 2)) master-locks)))
528 ;; FIXME: is it really necessary to reverse ?
529 (nreverse master-locks)))
530
531(defun vc-sccs-add-triple (name file rev)
532 (with-current-buffer
533 (find-file-noselect
534 (expand-file-name vc-sccs-name-assoc-file
535 (file-name-directory (vc-name file))))
536 (goto-char (point-max))
537 (insert name "\t:\t" file "\t" rev "\n")
538 (basic-save-buffer)
539 (kill-buffer (current-buffer))))
540
541(defun vc-sccs-lookup-triple (file name)
370fded4 542 "Return the numeric revision corresponding to a named tag of FILE.
5b5afd50 543If NAME is nil or a revision number string it's just passed through."
8f98485f
AS
544 (if (or (null name)
545 (let ((firstchar (aref name 0)))
546 (and (>= firstchar ?0) (<= firstchar ?9))))
547 name
548 (with-temp-buffer
549 (vc-insert-file
550 (expand-file-name vc-sccs-name-assoc-file
551 (file-name-directory (vc-name file))))
552 (vc-parse-buffer (concat name "\t:\t" file "\t\\(.+\\)") 1))))
7a004b71
GM
553
554(provide 'vc-sccs)
555
556;;; vc-sccs.el ends here