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