- (cond ((file-exists-p file)
- (cond (limit
- (if (not blocksize) (setq blocksize 8192))
- (let (found s)
- (while (not found)
- (setq s (buffer-size))
- (goto-char (1+ s))
- (setq found
- (or (zerop (car (cdr
- (insert-file-contents file nil s
- (+ s blocksize)))))
- (progn (beginning-of-line)
- (re-search-forward limit nil t)))))))
- (t (insert-file-contents file)))
- (set-buffer-modified-p nil)
- (auto-save-mode nil)
- t)
- (t nil)))
-
-(defun vc-parse-locks (file locks)
- ;; Parse RCS or SCCS locks.
- ;; The result is a list of the form ((VERSION USER) (VERSION USER) ...),
- ;; which is returned and stored into the property `vc-master-locks'.
- (if (not locks)
- (vc-file-setprop file 'vc-master-locks 'none)
- (let ((found t) (index 0) master-locks version user)
- (cond ((eq (vc-backend file) 'SCCS)
- (while (string-match "^\\([0-9.]+\\) [0-9.]+ \\([^ ]+\\) .*\n?"
- locks index)
- (setq version (substring locks
- (match-beginning 1) (match-end 1)))
- (setq user (substring locks
- (match-beginning 2) (match-end 2)))
- (setq master-locks (append master-locks
- (list (cons version user))))
- (setq index (match-end 0))))
- ((eq (vc-backend file) 'RCS)
- (while (string-match "[ \t\n]*\\([^:]+\\):\\([0-9.]+\\)"
- locks index)
- (setq version (substring locks
- (match-beginning 2) (match-end 2)))
- (setq user (substring locks
- (match-beginning 1) (match-end 1)))
- (setq master-locks (append master-locks
- (list (cons version user))))
- (setq index (match-end 0)))
- (if (string-match ";[ \t\n]+strict;" locks index)
- (vc-file-setprop file 'vc-checkout-model 'manual)
- (vc-file-setprop file 'vc-checkout-model 'implicit))))
- (vc-file-setprop file 'vc-master-locks (or master-locks 'none)))))
-
-(defun vc-simple-command (okstatus command file &rest args)
- ;; Simple version of vc-do-command, for use in vc-hooks only.
- ;; Don't switch to the *vc-info* buffer before running the
- ;; command, because that would change its default directory
- (save-excursion (set-buffer (get-buffer-create "*vc-info*"))
- (erase-buffer))
- (let ((exec-path (append vc-path exec-path)) exec-status
- ;; Add vc-path to PATH for the execution of this command.
- (process-environment
- (cons (concat "PATH=" (getenv "PATH")
- path-separator
- (mapconcat 'identity vc-path path-separator))
- process-environment)))
- (setq exec-status
- (apply 'call-process command nil "*vc-info*" nil
- (append args (list file))))
- (cond ((> exec-status okstatus)
- (switch-to-buffer (get-file-buffer file))
- (shrink-window-if-larger-than-buffer
- (display-buffer "*vc-info*"))
- (error "Couldn't find version control information")))
- exec-status))
-
-(defun vc-fetch-master-properties (file)
- ;; Fetch those properties of FILE that are stored in the master file.
- ;; For an RCS file, we don't get vc-latest-version vc-your-latest-version
- ;; here because that is slow.
- ;; That gets done if/when the functions vc-latest-version
- ;; and vc-your-latest-version get called.
- (save-excursion
- (cond
- ((eq (vc-backend file) 'SCCS)
- (set-buffer (get-buffer-create "*vc-info*"))
- (if (vc-insert-file (vc-lock-file file))
- (vc-parse-locks file (buffer-string))
- (vc-file-setprop file 'vc-master-locks 'none))
- (vc-insert-file (vc-name file) "^\001e")
- (vc-parse-buffer
- (list '("^\001d D \\([^ ]+\\)" 1)
- (list (concat "^\001d D \\([^ ]+\\) .* "
- (regexp-quote (user-login-name)) " ") 1))
- file
- '(vc-latest-version vc-your-latest-version)))
-
- ((eq (vc-backend file) 'RCS)
- (set-buffer (get-buffer-create "*vc-info*"))
- (vc-insert-file (vc-name file) "^[0-9]")
- (vc-parse-buffer
- (list '("^head[ \t\n]+\\([^;]+\\);" 1)
- '("^branch[ \t\n]+\\([^;]+\\);" 1)
- '("^locks[ \t\n]*\\([^;]*;\\([ \t\n]*strict;\\)?\\)" 1))
- file
- '(vc-head-version
- vc-default-branch
- vc-master-locks))
- ;; determine vc-master-workfile-version: it is either the head
- ;; of the trunk, the head of the default branch, or the
- ;; "default branch" itself, if that is a full revision number.
- (let ((default-branch (vc-file-getprop file 'vc-default-branch)))
- (cond
- ;; no default branch
- ((or (not default-branch) (string= "" default-branch))
- (vc-file-setprop file 'vc-master-workfile-version
- (vc-file-getprop file 'vc-head-version)))
- ;; default branch is actually a revision
- ((string-match "^[0-9]+\\.[0-9]+\\(\\.[0-9]+\\.[0-9]+\\)*$"
- default-branch)
- (vc-file-setprop file 'vc-master-workfile-version default-branch))
- ;; else, search for the head of the default branch
- (t (vc-insert-file (vc-name file) "^desc")
- (vc-parse-buffer (list (list
- (concat "^\\("
- (regexp-quote default-branch)
- "\\.[0-9]+\\)\ndate[ \t]+\\([0-9.]+\\);") 1 2))
- file '(vc-master-workfile-version)))))
- ;; translate the locks
- (vc-parse-locks file (vc-file-getprop file 'vc-master-locks)))
-
- ((eq (vc-backend file) 'CVS)
- (save-excursion
- ;; Call "cvs status" in the right directory, passing only the
- ;; nondirectory part of the file name -- otherwise CVS might
- ;; silently give a wrong result.
- (let ((default-directory (file-name-directory file)))
- (vc-simple-command 0 "cvs" (file-name-nondirectory file) "status"))
- (set-buffer (get-buffer "*vc-info*"))
- (vc-parse-buffer
- ;; CVS 1.3 says "RCS Version:", other releases "RCS Revision:",
- ;; and CVS 1.4a1 says "Repository revision:".
- '(("\\(RCS Version\\|RCS Revision\\|Repository revision\\):[\t ]+\\([0-9.]+\\)" 2)
- ("^File: [^ \t]+[ \t]+Status: \\(.*\\)" 1))
- file
- '(vc-latest-version vc-cvs-status))
- ;; Translate those status values that we understand into symbols.
- ;; Any other value is converted to nil.
- (let ((status (vc-file-getprop file 'vc-cvs-status)))
- (cond
- ((string-match "Up-to-date" status)
- (vc-file-setprop file 'vc-cvs-status 'up-to-date)
- (vc-file-setprop file 'vc-checkout-time
- (nth 5 (file-attributes file))))
- ((vc-file-setprop file 'vc-cvs-status
- (cond
- ((string-match "Locally Modified" status) 'locally-modified)
- ((string-match "Needs Merge" status) 'needs-merge)
- ((string-match "Needs \\(Checkout\\|Patch\\)" status)
- 'needs-checkout)
- ((string-match "Unresolved Conflict" status) 'unresolved-conflict)
- ((string-match "Locally Added" status) 'locally-added)
- (t 'unknown)
- ))))))))
- (if (get-buffer "*vc-info*")
- (kill-buffer (get-buffer "*vc-info*")))))
-
-;;; Functions that determine property values, by examining the
-;;; working file, the master file, or log program output
-
-(defun vc-consult-rcs-headers (file)
- ;; Search for RCS headers in FILE, and set properties
- ;; accordingly. This function can be disabled by setting
- ;; vc-consult-headers to nil.
- ;; Returns: nil if no headers were found
- ;; (or if the feature is disabled,
- ;; or if there is currently no buffer
- ;; visiting FILE)
- ;; 'rev if a workfile revision was found
- ;; 'rev-and-lock if revision and lock info was found
- (cond
- ((or (not vc-consult-headers)
- (not (get-file-buffer file))) nil)
- ((let (status version locking-user)
- (save-excursion
- (set-buffer (get-file-buffer file))
- (goto-char (point-min))
- (cond
- ;; search for $Id or $Header
- ;; -------------------------
- ((or (and (search-forward "$Id: " nil t)
- (looking-at "[^ ]+ \\([0-9.]+\\) "))
- (and (progn (goto-char (point-min))
- (search-forward "$Header: " nil t))
- (looking-at "[^ ]+ \\([0-9.]+\\) ")))
- (goto-char (match-end 0))
- ;; if found, store the revision number ...
- (setq version (buffer-substring (match-beginning 1) (match-end 1)))
- ;; ... and check for the locking state
- (cond
- ((looking-at
- (concat "[0-9]+[/-][01][0-9][/-][0-3][0-9] " ; date
- "[0-2][0-9]:[0-5][0-9]+:[0-6][0-9]+\\([+-][0-9:]+\\)? " ; time
- "[^ ]+ [^ ]+ ")) ; author & state
- (goto-char (match-end 0)) ; [0-6] in regexp handles leap seconds
- (cond
- ;; unlocked revision
- ((looking-at "\\$")
- (setq locking-user 'none)
- (setq status 'rev-and-lock))
- ;; revision is locked by some user
- ((looking-at "\\([^ ]+\\) \\$")
- (setq locking-user
- (buffer-substring (match-beginning 1) (match-end 1)))
- (setq status 'rev-and-lock))
- ;; everything else: false
- (nil)))
- ;; unexpected information in
- ;; keyword string --> quit
- (nil)))
- ;; search for $Revision
- ;; --------------------
- ((re-search-forward (concat "\\$"
- "Revision: \\([0-9.]+\\) \\$")
- nil t)
- ;; if found, store the revision number ...
- (setq version (buffer-substring (match-beginning 1) (match-end 1)))
- ;; and see if there's any lock information
- (goto-char (point-min))
- (if (re-search-forward (concat "\\$" "Locker:") nil t)
- (cond ((looking-at " \\([^ ]+\\) \\$")
- (setq locking-user (buffer-substring (match-beginning 1)
- (match-end 1)))
- (setq status 'rev-and-lock))
- ((looking-at " *\\$")
- (setq locking-user 'none)
- (setq status 'rev-and-lock))
- (t
- (setq locking-user 'none)
- (setq status 'rev-and-lock)))
- (setq status 'rev)))
- ;; else: nothing found
- ;; -------------------
- (t nil)))
- (if status (vc-file-setprop file 'vc-workfile-version version))
- (and (eq status 'rev-and-lock)
- (eq (vc-backend file) 'RCS)
- (vc-file-setprop file 'vc-locking-user locking-user)
- ;; If the file has headers, we don't want to query the master file,
- ;; because that would eliminate all the performance gain the headers
- ;; brought us. We therefore use a heuristic for the checkout model
- ;; now: If we trust the file permissions, and the file is not
- ;; locked, then if the file is read-only the checkout model is
- ;; `manual', otherwise `implicit'.
- (not (vc-mistrust-permissions file))
- (not (vc-locking-user file))
- (if (string-match ".r-..-..-." (nth 8 (file-attributes file)))
- (vc-file-setprop file 'vc-checkout-model 'manual)
- (vc-file-setprop file 'vc-checkout-model 'implicit)))
- status))))
-
-;;; Access functions to file properties
-;;; (Properties should be _set_ using vc-file-setprop, but
-;;; _retrieved_ only through these functions, which decide
-;;; if the property is already known or not. A property should
-;;; only be retrieved by vc-file-getprop if there is no
-;;; access function.)
-
-;;; properties indicating the backend
-;;; being used for FILE
-
-(defun vc-backend-subdirectory-name (&optional file)
- ;; Where the master and lock files for the current directory are kept
- (symbol-name
- (or
- (and file (vc-backend file))
- vc-default-back-end
- (setq vc-default-back-end (if (vc-find-binary "rcs") 'RCS 'SCCS)))))