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 Free Software Foundation, Inc.
5
6;; Author:     FSF (see vc.el for full credits)
7;; Maintainer: Andre Spiegel <spiegel@gnu.org>
8
9;; $Id$
10
11;; This file is part of GNU Emacs.
12
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)
16;; any later version.
17
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.
22
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.
27
28;;; Commentary:
29
30;;; Code:
31
32(eval-when-compile
33  (require 'vc))
34
35;;;
36;;; Customization options
37;;;
38
39(defcustom vc-sccs-register-switches nil
40  "*Extra switches for registering a file in SCCS.
41A 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"
46			 :value ("")
47			 string))
48  :version "21.1"
49  :group 'vc)
50
51(defcustom vc-sccs-diff-switches nil
52  "*A string or list of strings specifying extra switches for `vcdiff',
53the diff utility used for SCCS under VC."
54    :type '(choice (const :tag "None" nil)
55		 (string :tag "Argument String")
56		 (repeat :tag "Argument List"
57			 :value ("")
58			 string))
59  :version "21.1"
60  :group 'vc)
61
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)
65  :group 'vc)
66
67;;;###autoload
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.
71For 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"
75			 (choice string
76				 function)))
77  :version "21.1"
78  :group 'vc)
79
80
81;;;
82;;; Internal variables
83;;;
84
85(defconst vc-sccs-name-assoc-file "VC-names")
86
87
88;;;
89;;; State-querying functions
90;;;
91
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.
96
97;;;###autoload (defun vc-sccs-registered(f) (vc-default-registered 'SCCS f))
98(defun vc-sccs-registered (f) (vc-default-registered 'SCCS f))
99
100(defun vc-sccs-state (file)
101  "SCCS-specific function to compute the version control state."
102  (with-temp-buffer
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)
109                  'up-to-date
110                'unlocked-changes)
111            (if (string= locking-user (vc-user-login-name file))
112                'edited
113              locking-user)))
114      'up-to-date)))
115
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      (let* ((attributes  (file-attributes file 'string))
126             (owner-name  (nth 2 attributes))
127             (permissions (nth 8 attributes)))
128	(if (string-match ".r-..-..-." permissions)
129            'up-to-date
130          (if (string-match ".rw..-..-." permissions)
131              (if (file-ownership-preserved-p file)
132                  'edited
133                owner-name)
134            ;; Strange permissions.
135            ;; Fall through to real state computation.
136            (vc-sccs-state file))))
137    (vc-sccs-state file)))
138
139(defun vc-sccs-workfile-version (file)
140  "SCCS-specific version of `vc-workfile-version'."
141  (with-temp-buffer
142    ;; The workfile version is always the latest version number.
143    ;; To find this number, search the entire delta table,
144    ;; rather than just the first entry, because the
145    ;; first entry might be a deleted ("R") version.
146    (vc-insert-file (vc-name file) "^\001e\n\001[^s]")
147    (vc-parse-buffer "^\001d D \\([^ ]+\\)" 1)))
148
149(defun vc-sccs-checkout-model (file)
150  "SCCS-specific version of `vc-checkout-model'."
151  'locking)
152
153(defun vc-sccs-workfile-unchanged-p (file)
154  "SCCS-specific implementation of `vc-workfile-unchanged-p'."
155  (zerop (apply 'vc-do-command nil 1 "vcdiff" (vc-name file)
156                (list "--brief" "-q"
157                      (concat "-r" (vc-workfile-version file))))))
158
159
160;;;
161;;; State-changing functions
162;;;
163
164(defun vc-sccs-register (file &optional rev comment)
165  "Register FILE into the SCCS version-control system.
166REV is the optional revision number for the file.  COMMENT can be used
167to provide an initial description of FILE.
168
169`vc-register-switches' and `vc-sccs-register-switches' are passed to
170the SCCS command (in that order).
171
172Automatically retrieve a read-only version of the file with keywords
173expanded if `vc-keep-workfiles' is non-nil, otherwise, delete the workfile."
174    (let* ((dirname (or (file-name-directory file) ""))
175	   (basename (file-name-nondirectory file))
176	   (project-file (vc-sccs-search-project-dir dirname basename)))
177      (let ((vc-name
178	     (or project-file
179		 (format (car vc-sccs-master-templates) dirname basename))))
180	(apply 'vc-do-command nil 0 "admin" vc-name
181	       (and rev (concat "-r" rev))
182	       "-fb"
183	       (concat "-i" (file-relative-name file))
184	       (and comment (concat "-y" comment))
185	       (vc-switches 'SCCS 'register)))
186      (delete-file file)
187      (if vc-keep-workfiles
188	  (vc-do-command nil 0 "get" (vc-name file)))))
189
190(defun vc-sccs-responsible-p (file)
191  "Return non-nil if SCCS thinks it would be responsible for registering FILE."
192  ;; TODO: check for all the patterns in vc-sccs-master-templates
193  (or (file-directory-p (expand-file-name "SCCS" (file-name-directory file)))
194      (stringp (vc-sccs-search-project-dir (or (file-name-directory file) "")
195					   (file-name-nondirectory file)))))
196
197(defun vc-sccs-checkin (file rev comment)
198  "SCCS-specific version of `vc-backend-checkin'."
199  (apply 'vc-do-command nil 0 "delta" (vc-name file)
200	 (if rev (concat "-r" rev))
201	 (concat "-y" comment)
202	 (vc-switches 'SCCS 'checkin))
203  (if vc-keep-workfiles
204      (vc-do-command nil 0 "get" (vc-name file))))
205
206(defun vc-sccs-find-version (file rev buffer)
207  (apply 'vc-do-command
208	 buffer 0 "get" (vc-name file)
209	 "-s" ;; suppress diagnostic output
210	 "-p"
211	 (and rev
212	      (concat "-r"
213		      (vc-sccs-lookup-triple file rev)))
214	 (vc-switches 'SCCS 'checkout)))
215
216(defun vc-sccs-checkout (file &optional editable rev)
217  "Retrieve a copy of a saved version of SCCS controlled FILE.
218EDITABLE non-nil means that the file should be writable and
219locked.  REV is the revision to check out."
220  (let ((file-buffer (get-file-buffer file))
221	switches)
222    (message "Checking out %s..." file)
223    (save-excursion
224      ;; Change buffers to get local value of vc-checkout-switches.
225      (if file-buffer (set-buffer file-buffer))
226      (setq switches (vc-switches 'SCCS 'checkout))
227      ;; Save this buffer's default-directory
228      ;; and use save-excursion to make sure it is restored
229      ;; in the same buffer it was saved in.
230      (let ((default-directory default-directory))
231	(save-excursion
232	  ;; Adjust the default-directory so that the check-out creates
233	  ;; the file in the right place.
234	  (setq default-directory (file-name-directory file))
235
236	  (and rev (or (string= rev "")
237                       (not (stringp rev)))
238               (setq rev nil))
239	  (apply 'vc-do-command nil 0 "get" (vc-name file)
240		 (if editable "-e")
241		 (and rev (concat "-r" (vc-sccs-lookup-triple file rev)))
242		 switches))))
243    (message "Checking out %s...done" file)))
244
245(defun vc-sccs-revert (file &optional contents-done)
246  "Revert FILE to the version it was based on."
247  (vc-do-command nil 0 "unget" (vc-name file))
248  (vc-do-command nil 0 "get" (vc-name file))
249  ;; Checking out explicit versions is not supported under SCCS, yet.
250  ;; We always "revert" to the latest version; therefore
251  ;; vc-workfile-version is cleared here so that it gets recomputed.
252  (vc-file-setprop file 'vc-workfile-version nil))
253
254(defun vc-sccs-cancel-version (file editable)
255  "Undo the most recent checkin of FILE.
256EDITABLE non-nil means previous version should be locked."
257  (vc-do-command nil 0 "rmdel"
258		 (vc-name file)
259		 (concat "-r" (vc-workfile-version file)))
260  (vc-do-command nil 0 "get"
261		 (vc-name file)
262		 (if editable "-e")))
263
264(defun vc-sccs-steal-lock (file &optional rev)
265  "Steal the lock on the current workfile for FILE and revision REV."
266  (vc-do-command nil 0 "unget" (vc-name file) "-n" (if rev (concat "-r" rev)))
267  (vc-do-command nil 0 "get" (vc-name file) "-g" (if rev (concat "-r" rev))))
268
269
270;;;
271;;; History functions
272;;;
273
274(defun vc-sccs-print-log (file &optional buffer)
275  "Get change log associated with FILE."
276  (vc-do-command buffer 0 "prs" (vc-name file)))
277
278(defun vc-sccs-logentry-check ()
279  "Check that the log entry in the current buffer is acceptable for SCCS."
280  (when (>= (buffer-size) 512)
281    (goto-char 512)
282    (error "Log must be less than 512 characters; point is now at pos 512")))
283
284(defun vc-sccs-diff (file &optional oldvers newvers buffer)
285  "Get a difference report using SCCS between two versions of FILE."
286  (setq oldvers (vc-sccs-lookup-triple file oldvers))
287  (setq newvers (vc-sccs-lookup-triple file newvers))
288  (apply 'vc-do-command (or buffer "*vc-diff*") 1 "vcdiff" (vc-name file)
289         (append (list "-q"
290                       (and oldvers (concat "-r" oldvers))
291                       (and newvers (concat "-r" newvers)))
292                 (vc-switches 'SCCS 'diff))))
293
294
295;;;
296;;; Snapshot system
297;;;
298
299(defun vc-sccs-assign-name (file name)
300  "Assign to FILE's latest version a given NAME."
301  (vc-sccs-add-triple name file (vc-workfile-version file)))
302
303
304;;;
305;;; Miscellaneous
306;;;
307
308(defun vc-sccs-check-headers ()
309  "Check if the current file has any headers in it."
310  (save-excursion
311    (goto-char (point-min))
312    (re-search-forward  "%[A-Z]%" nil t)))
313
314(defun vc-sccs-rename-file (old new)
315  ;; Move the master file (using vc-rcs-master-templates).
316  (vc-rename-master (vc-name old) new vc-sccs-master-templates)
317  ;; Update the snapshot file.
318  (with-current-buffer
319      (find-file-noselect
320       (expand-file-name vc-sccs-name-assoc-file
321			 (file-name-directory (vc-name old))))
322    (goto-char (point-min))
323    ;; (replace-regexp (concat ":" (regexp-quote old) "$") (concat ":" new))
324    (while (re-search-forward (concat ":" (regexp-quote old) "$") nil t)
325      (replace-match (concat ":" new) nil nil))
326    (basic-save-buffer)
327    (kill-buffer (current-buffer))))
328
329
330;;;
331;;; Internal functions
332;;;
333
334;; This function is wrapped with `progn' so that the autoload cookie
335;; copies the whole function itself into loaddefs.el rather than just placing
336;; a (autoload 'vc-sccs-search-project-dir "vc-sccs") which would not
337;; help us avoid loading vc-sccs.
338;;;###autoload
339(progn (defun vc-sccs-search-project-dir (dirname basename)
340  "Return the name of a master file in the SCCS project directory.
341Does not check whether the file exists but returns nil if it does not
342find any project directory."
343  (let ((project-dir (getenv "PROJECTDIR")) dirs dir)
344    (when project-dir
345      (if (file-name-absolute-p project-dir)
346	  (setq dirs '("SCCS" ""))
347	(setq dirs '("src/SCCS" "src" "source/SCCS" "source"))
348	(setq project-dir (expand-file-name (concat "~" project-dir))))
349      (while (and (not dir) dirs)
350	(setq dir (expand-file-name (car dirs) project-dir))
351	(unless (file-directory-p dir)
352	  (setq dir nil)
353	  (setq dirs (cdr dirs))))
354      (and dir (expand-file-name (concat "s." basename) dir))))))
355
356(defun vc-sccs-lock-file (file)
357  "Generate lock file name corresponding to FILE."
358  (let ((master (vc-name file)))
359    (and
360     master
361     (string-match "\\(.*/\\)\\(s\\.\\)\\(.*\\)" master)
362     (replace-match "p." t t master 2))))
363
364(defun vc-sccs-parse-locks ()
365  "Parse SCCS locks in current buffer.
366The result is a list of the form ((VERSION . USER) (VERSION . USER) ...)."
367  (let (master-locks)
368    (goto-char (point-min))
369    (while (re-search-forward "^\\([0-9.]+\\) [0-9.]+ \\([^ ]+\\) .*\n?"
370			      nil t)
371      (setq master-locks
372	    (cons (cons (match-string 1) (match-string 2)) master-locks)))
373    ;; FIXME: is it really necessary to reverse ?
374    (nreverse master-locks)))
375
376(defun vc-sccs-add-triple (name file rev)
377  (with-current-buffer
378      (find-file-noselect
379       (expand-file-name vc-sccs-name-assoc-file
380			 (file-name-directory (vc-name file))))
381    (goto-char (point-max))
382    (insert name "\t:\t" file "\t" rev "\n")
383    (basic-save-buffer)
384    (kill-buffer (current-buffer))))
385
386(defun vc-sccs-lookup-triple (file name)
387  "Return the numeric version corresponding to a named snapshot of FILE.
388If NAME is nil or a version number string it's just passed through."
389  (if (or (null name)
390	  (let ((firstchar (aref name 0)))
391	    (and (>= firstchar ?0) (<= firstchar ?9))))
392      name
393    (with-temp-buffer
394      (vc-insert-file
395       (expand-file-name vc-sccs-name-assoc-file
396			 (file-name-directory (vc-name file))))
397      (vc-parse-buffer (concat name "\t:\t" file "\t\\(.+\\)") 1))))
398
399(provide 'vc-sccs)
400
401;; arch-tag: d751dee3-d7b3-47e1-95e3-7ae98c052041
402;;; vc-sccs.el ends here
403