X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/b578f267af27af50e3c091f8c9c9eee939b69978..fadbdfeafe838d0ce1ca3e713b05243cb8d6e296:/lisp/vc-hooks.el diff --git a/lisp/vc-hooks.el b/lisp/vc-hooks.el index 9fbe79508a..5591d49081 100644 --- a/lisp/vc-hooks.el +++ b/lisp/vc-hooks.el @@ -1,11 +1,11 @@ ;;; vc-hooks.el --- resident support for version-control -;; Copyright (C) 1992, 1993, 1994, 1995 Free Software Foundation, Inc. +;; Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998 Free Software Foundation, Inc. -;; Author: Eric S. Raymond -;; Modified by: -;; Per Cederqvist -;; Andre Spiegel +;; Author: Eric S. Raymond +;; Maintainer: Andre Spiegel + +;; $Id: vc-hooks.el,v 1.1 2000/01/10 13:25:12 gerd Exp gerd $ ;; This file is part of GNU Emacs. @@ -35,38 +35,52 @@ ;; Customization Variables (the rest is in vc.el) -(defvar vc-default-back-end nil +(defcustom vc-default-back-end nil "*Back-end actually used by this interface; may be SCCS or RCS. -The value is only computed when needed to avoid an expensive search.") +The value is only computed when needed to avoid an expensive search." + :type '(choice (const nil) (const RCS) (const SCCS)) + :group 'vc) -(defvar vc-handle-cvs t +(defcustom vc-handle-cvs t "*If non-nil, use VC for files managed with CVS. -If it is nil, don't use VC for those files.") +If it is nil, don't use VC for those files." + :type 'boolean + :group 'vc) -(defvar vc-rcsdiff-knows-brief nil +(defcustom vc-rcsdiff-knows-brief nil "*Indicates whether rcsdiff understands the --brief option. The value is either `yes', `no', or nil. If it is nil, VC tries -to use --brief and sets this variable to remember whether it worked.") +to use --brief and sets this variable to remember whether it worked." + :type '(choice (const nil) (const yes) (const no)) + :group 'vc) -(defvar vc-path +(defcustom vc-path (if (file-directory-p "/usr/sccs") '("/usr/sccs") nil) - "*List of extra directories to search for version control commands.") + "*List of extra directories to search for version control commands." + :type '(repeat directory) + :group 'vc) -(defvar vc-master-templates +(defcustom vc-master-templates '(("%sRCS/%s,v" . RCS) ("%s%s,v" . RCS) ("%sRCS/%s" . RCS) ("%sSCCS/s.%s" . SCCS) ("%ss.%s". SCCS) - vc-find-cvs-master) + vc-find-cvs-master + vc-search-sccs-project-dir) "*Where to look for version-control master files. The first pair corresponding to a given back end is used as a template -when creating new masters.") +when creating new masters. +Setting this variable to nil turns off use of VC entirely." + :type '(repeat sexp) + :group 'vc) -(defvar vc-make-backup-files nil +(defcustom vc-make-backup-files nil "*If non-nil, backups of registered files are made as with other files. -If nil (the default), files covered by version control don't get backups.") +If nil (the default), files covered by version control don't get backups." + :type 'boolean + :group 'vc) -(defvar vc-follow-symlinks 'ask +(defcustom vc-follow-symlinks 'ask "*Indicates what to do if you visit a symbolic link to a file that is under version control. Editing such a file through the link bypasses the version control system, which is dangerous and @@ -74,24 +88,45 @@ probably not what you want. If this variable is t, VC follows the link and visits the real file, telling you about it in the echo area. If it is `ask', VC asks for confirmation whether it should follow the link. If nil, the link is -visited and a warning displayed.") +visited and a warning displayed." + :type '(choice (const ask) (const nil) (const t)) + :group 'vc) -(defvar vc-display-status t +(defcustom vc-display-status t "*If non-nil, display revision number and lock status in modeline. -Otherwise, not displayed.") +Otherwise, not displayed." + :type 'boolean + :group 'vc) + -(defvar vc-consult-headers t - "*If non-nil, identify work files by searching for version headers.") +(defcustom vc-consult-headers t + "*If non-nil, identify work files by searching for version headers." + :type 'boolean + :group 'vc) -(defvar vc-keep-workfiles t +(defcustom vc-keep-workfiles t "*If non-nil, don't delete working files after registering changes. If the back-end is CVS, workfiles are always kept, regardless of the -value of this flag.") +value of this flag." + :type 'boolean + :group 'vc) -(defvar vc-mistrust-permissions nil +(defcustom vc-mistrust-permissions nil "*If non-nil, don't assume that permissions and ownership track version-control status. If nil, do rely on the permissions. -See also variable `vc-consult-headers'.") +See also variable `vc-consult-headers'." + :type 'boolean + :group 'vc) + +(defcustom vc-ignore-vc-files nil + "*If non-nil don't look for version control information when finding files. + +It may be useful to set this if (say) you edit files in a directory +containing corresponding RCS files but don't have RCS available; +similarly for other version control systems." + :type 'boolean + :group 'vc + :version "20.3") (defun vc-mistrust-permissions (file) ;; Access function to the above. @@ -159,7 +194,7 @@ See also variable `vc-consult-headers'.") ;; number of the subexpression that should be returned. If there's ;; a third element (also the number of a subexpression), that ;; subexpression is assumed to be a date field and we want the most - ;; recent entry matching the template. + ;; recent entry matching the template; this works for RCS format dates only. ;; If FILE and PROPERTIES are given, the latter must be a list of ;; properties of the same length as PATTERNS; each property is assigned ;; the corresponding value. @@ -178,6 +213,13 @@ See also variable `vc-consult-headers'.") (let ((latest-date "") (latest-val)) (while (re-search-forward (car p) nil t) (let ((date (vc-match-substring (elt p 2)))) + ;; Most (but not all) versions of RCS use two-digit years + ;; to represent dates in the range 1900 through 1999. + ;; The two-digit and four-digit notations can both appear + ;; in the same file. Normalize the two-digit versions. + (save-match-data + (if (string-match "\\`[0-9][0-9]\\." date) + (setq date (concat "19" date)))) (if (string< latest-date date) (progn (setq latest-date date) @@ -272,6 +314,45 @@ See also variable `vc-consult-headers'.") (error "Couldn't find version control information"))) exec-status)) +(defun vc-parse-cvs-status (&optional full) + ;; Parse output of "cvs status" command in the current buffer and + ;; set file properties accordingly. Unless FULL is t, parse only + ;; essential information. + (let (file status) + (goto-char (point-min)) + (if (re-search-forward "^File: " nil t) + (cond + ((looking-at "no file") nil) + ((re-search-forward "\\=\\([^ \t]+\\)" nil t) + (setq file (concat default-directory (match-string 1))) + (vc-file-setprop file 'vc-backend 'CVS) + (if (not (re-search-forward "\\=[ \t]+Status: \\(.*\\)" nil t)) + (setq status "Unknown") + (setq status (match-string 1))) + (if (and full + (re-search-forward + "\\(RCS Version\\|RCS Revision\\|Repository revision\\):[\t ]+\\([0-9.]+\\)" + nil t)) + (vc-file-setprop file 'vc-latest-version (match-string 2))) + (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 "File had conflicts on merge" status) + 'unresolved-conflict) + ((string-match "Locally Added" status) 'locally-added) + ((string-match "New file!" status) 'locally-added) + (t 'unknown)))))))))) + (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 @@ -289,7 +370,7 @@ See also variable `vc-consult-headers'.") (vc-parse-buffer (list '("^\001d D \\([^ ]+\\)" 1) (list (concat "^\001d D \\([^ ]+\\) .* " - (regexp-quote (user-login-name)) " ") 1)) + (regexp-quote (vc-user-login-name)) " ") 1)) file '(vc-latest-version vc-your-latest-version))) @@ -335,31 +416,7 @@ See also variable `vc-consult-headers'.") (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) - )))))))) + (vc-parse-cvs-status t)))) (if (get-buffer "*vc-info*") (kill-buffer (get-buffer "*vc-info*"))))) @@ -386,14 +443,16 @@ See also variable `vc-consult-headers'.") (cond ;; search for $Id or $Header ;; ------------------------- - ((or (and (search-forward "$Id: " nil t) + ;; The `\ 's below avoid an RCS 5.7 bug when checking in this file. + ((or (and (search-forward "$Id\ : " nil t) (looking-at "[^ ]+ \\([0-9.]+\\) ")) (and (progn (goto-char (point-min)) - (search-forward "$Header: " nil t)) + (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))) + (setq version (buffer-substring-no-properties (match-beginning 1) + (match-end 1))) ;; ... and check for the locking state (cond ((looking-at @@ -409,7 +468,8 @@ See also variable `vc-consult-headers'.") ;; revision is locked by some user ((looking-at "\\([^ ]+\\) \\$") (setq locking-user - (buffer-substring (match-beginning 1) (match-end 1))) + (buffer-substring-no-properties (match-beginning 1) + (match-end 1))) (setq status 'rev-and-lock)) ;; everything else: false (nil))) @@ -422,13 +482,15 @@ See also variable `vc-consult-headers'.") "Revision: \\([0-9.]+\\) \\$") nil t) ;; if found, store the revision number ... - (setq version (buffer-substring (match-beginning 1) (match-end 1))) + (setq version (buffer-substring-no-properties (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 locking-user (buffer-substring-no-properties + (match-beginning 1) + (match-end 1))) (setq status 'rev-and-lock)) ((looking-at " *\\$") (setq locking-user 'none) @@ -479,21 +541,26 @@ See also variable `vc-consult-headers'.") "Return the master name of a file, nil if it is not registered. For CVS, the full name of CVS/Entries is returned." (or (vc-file-getprop file 'vc-name) - (let ((name-and-type (vc-registered file))) - (if name-and-type - (progn - (vc-file-setprop file 'vc-backend (cdr name-and-type)) - (vc-file-setprop file 'vc-name (car name-and-type))))))) + ;; Use the caching mechanism of vc-backend, below. + (if (vc-backend file) + (vc-file-getprop file 'vc-name)))) (defun vc-backend (file) "Return the version-control type of a file, nil if it is not registered." - (and file - (or (vc-file-getprop file 'vc-backend) - (let ((name-and-type (vc-registered file))) - (if name-and-type - (progn - (vc-file-setprop file 'vc-name (car name-and-type)) - (vc-file-setprop file 'vc-backend (cdr name-and-type)))))))) + ;; Note that internally, Emacs remembers unregistered + ;; files by setting the property to `none'. + (if file + (let ((property (vc-file-getprop file 'vc-backend)) + (name-and-type)) + (cond ((eq property 'none) nil) + (property) + (t (setq name-and-type (vc-registered file)) + (if name-and-type + (progn + (vc-file-setprop file 'vc-name (car name-and-type)) + (vc-file-setprop file 'vc-backend (cdr name-and-type))) + (vc-file-setprop file 'vc-backend 'none) + nil)))))) (defun vc-checkout-model (file) ;; Return `manual' if the user has to type C-x C-q to check out FILE. @@ -510,7 +577,16 @@ For CVS, the full name of CVS/Entries is returned." (vc-file-getprop file 'vc-checkout-model)))) ((eq (vc-backend file) 'CVS) (vc-file-setprop file 'vc-checkout-model - (if (getenv "CVSREAD") 'manual 'implicit)))))) + (cond + ((getenv "CVSREAD") 'manual) + ;; If the file is not writeable, this is probably because the + ;; file is being "watched" by other developers. Use "manual" + ;; checkout in this case. (If vc-mistrust-permissions was t, + ;; we actually shouldn't trust this, but there is no other way + ;; to learn this from CVS at the moment (version 1.9).) + ((string-match "r-..-..-." (nth 8 (file-attributes file))) + 'manual) + (t 'implicit))))))) ;;; properties indicating the locking state @@ -560,24 +636,22 @@ For CVS, the full name of CVS/Entries is returned." (vc-file-setprop file 'vc-locking-user 'none)) ((and (= (nth 2 attributes) (user-uid)) (string-match ".rw..-..-." (nth 8 attributes))) - (vc-file-setprop file 'vc-locking-user (user-login-name))) + (vc-file-setprop file 'vc-locking-user (vc-user-login-name))) (nil))))) +(defun vc-user-login-name (&optional uid) + ;; Return the name under which the user is logged in, as a string. + ;; (With optional argument UID, return the name of that user.) + ;; This function does the same as `user-login-name', but unlike + ;; that, it never returns nil. If a UID cannot be resolved, that + ;; UID is returned as a string. + (or (user-login-name uid) + (and uid (number-to-string uid)) + (number-to-string (user-uid)))) + (defun vc-file-owner (file) - ;; The expression below should return the username of the owner - ;; of the file. It doesn't. It returns the username if it is - ;; you, or otherwise the UID of the owner of the file. The - ;; return value from this function is only used by - ;; vc-dired-reformat-line, and it does the proper thing if a UID - ;; is returned. - ;; The *proper* way to fix this would be to implement a built-in - ;; function in Emacs, say, (username UID), that returns the - ;; username of a given UID. - ;; The result of this hack is that vc-directory will print the - ;; name of the owner of the file for any files that are - ;; modified. - (let ((uid (nth 2 (file-attributes file)))) - (if (= uid (user-uid)) (user-login-name) uid))) + ;; Return who owns FILE (user name, as a string). + (vc-user-login-name (nth 2 (file-attributes file)))) (defun vc-rcs-lock-from-diff (file) ;; Diff the file against the master version. If differences are found, @@ -600,8 +674,7 @@ For CVS, the full name of CVS/Entries is returned." (defun vc-locking-user (file) ;; Return the name of the person currently holding a lock on FILE. - ;; Return nil if there is no such person. (Sometimes, not the name - ;; of the locking user but his uid will be returned.) + ;; Return nil if there is no such person. ;; Under CVS, a file is considered locked if it has been modified since ;; it was checked out. ;; The property is cached. It is only looked up if it is currently nil. @@ -621,10 +694,7 @@ For CVS, the full name of CVS/Entries is returned." (and (equal (vc-file-getprop file 'vc-checkout-time) (nth 5 (file-attributes file))) (vc-file-setprop file 'vc-locking-user 'none)) - (let ((locker (vc-file-owner file))) - (vc-file-setprop file 'vc-locking-user - (if (stringp locker) locker - (format "%d" locker)))))) + (vc-file-setprop file 'vc-locking-user (vc-file-owner file)))) ((eq (vc-backend file) 'RCS) (let (p-lock) @@ -698,7 +768,7 @@ For CVS, the full name of CVS/Entries is returned." (list (concat "^\\([0-9]+\\.[0-9.]+\\)\n" "date[ \t]+\\([0-9.]+\\);[ \t]+" "author[ \t]+" - (regexp-quote (user-login-name)) ";") 1 2)) + (regexp-quote (vc-user-login-name)) ";") 1 2)) file '(vc-latest-version vc-your-latest-version)) (if (get-buffer "*vc-info*") @@ -764,23 +834,50 @@ For CVS, the full name of CVS/Entries is returned." vc-master-templates) nil))))) -(defun vc-utc-string (timeval) - ;; Convert a time value into universal time, and return it as a - ;; human-readable string. This is for comparing CVS checkout times - ;; with file modification times. - (let (utc (high (car timeval)) (low (nth 1 timeval)) - (offset (car (current-time-zone timeval)))) - (setq low (- low offset)) - (setq utc (if (> low 65535) - (list (1+ high) (- low 65536)) - (if (< low 0) - (list (1- high) (+ 65536 low)) - (list high low)))) - (current-time-string utc))) - +(defun vc-sccs-project-dir () + ;; Return the full pathname of the SCCS PROJECTDIR, if it exists, + ;; otherwise nil. The PROJECTDIR is indicated by the environment + ;; variable of the same name. If its value starts with a slash, + ;; it must be an absolute path name that points to the + ;; directory where SCCS history files reside. If it does not + ;; begin with a slash, it is taken as the name of a user, + ;; and history files reside in an "src" or "source" subdirectory + ;; of that user's home directory. + (let ((project-dir (getenv "PROJECTDIR"))) + (and project-dir + (if (eq (elt project-dir 0) ?/) + (if (file-exists-p (concat project-dir "/SCCS")) + (concat project-dir "/SCCS/") + (if (file-exists-p project-dir) + project-dir)) + (setq project-dir (expand-file-name (concat "~" project-dir))) + (let (trial) + (setq trial (concat project-dir "/src/SCCS")) + (if (file-exists-p trial) + (concat trial "/") + (setq trial (concat project-dir "/src")) + (if (file-exists-p trial) + (concat trial "/") + (setq trial (concat project-dir "/source/SCCS")) + (if (file-exists-p trial) + (concat trial "/") + (setq trial (concat project-dir "/source/")) + (if (file-exists-p trial) + (concat trial "/")))))))))) + +(defun vc-search-sccs-project-dir (dirname basename) + ;; Check if there is a master file for BASENAME in the + ;; SCCS project directory. If yes, throw `found' as + ;; expected by vc-registered. If not, return nil. + (let* ((project-dir (vc-sccs-project-dir)) + (master-file (and project-dir (concat project-dir "s." basename)))) + (and master-file + (file-exists-p master-file) + (throw 'found (cons master-file 'SCCS))))) + (defun vc-find-cvs-master (dirname basename) ;; Check if DIRNAME/BASENAME is handled by CVS. - ;; If it is, do a (throw 'found (cons MASTER 'CVS)). + ;; If it is, do a (throw 'found (cons MASTER-FILE 'CVS)). ;; Note: This function throws the name of CVS/Entries ;; NOT that of the RCS master file (because we wouldn't be able ;; to access it under remote CVS). @@ -788,22 +885,38 @@ For CVS, the full name of CVS/Entries is returned." (if (and vc-handle-cvs (file-directory-p (concat dirname "CVS/")) (file-readable-p (concat dirname "CVS/Entries"))) - (let (buffer time (fold case-fold-search) - (file (concat dirname basename))) + (let ((file (concat dirname basename)) + buffer) (unwind-protect (save-excursion (setq buffer (set-buffer (get-buffer-create "*vc-info*"))) (vc-insert-file (concat dirname "CVS/Entries")) (goto-char (point-min)) - ;; make sure the file name is searched - ;; case-sensitively + ;; make sure that the file name is searched + ;; case-sensitively - case-fold-search is a buffer-local + ;; variable, so setting it here won't affect any other buffers (setq case-fold-search nil) (cond + ;; entry for a "locally added" file (not yet committed) + ((re-search-forward + (concat "^/" (regexp-quote basename) "/0/") nil t) + (vc-file-setprop file 'vc-checkout-time 0) + (vc-file-setprop file 'vc-workfile-version "0") + (throw 'found (cons (concat dirname "CVS/Entries") 'CVS))) + ;; normal entry ((re-search-forward (concat "^/" (regexp-quote basename) - "/\\([^/]*\\)/\\([^/]*\\)/") + ;; revision + "/\\([^/]*\\)" + ;; timestamp + "/[A-Z][a-z][a-z]" ;; week day (irrelevant) + " \\([A-Z][a-z][a-z]\\)" ;; month name + " *\\([0-9]*\\)" ;; day of month + " \\([0-9]*\\):\\([0-9]*\\):\\([0-9]*\\)" ;; hms + " \\([0-9]*\\)" ;; year + ;; optional conflict field + "\\(+[^/]*\\)?/") nil t) - (setq case-fold-search fold) ;; restore the old value ;; We found it. Store away version number now that we ;; are anyhow so close to finding it. (vc-file-setprop file @@ -811,13 +924,40 @@ For CVS, the full name of CVS/Entries is returned." (match-string 1)) ;; If the file hasn't been modified since checkout, ;; store the checkout-time. - (let ((mtime (nth 5 (file-attributes file)))) - (if (string= (match-string 2) (vc-utc-string mtime)) + (let ((mtime (nth 5 (file-attributes file))) + (second (string-to-number (match-string 6))) + (minute (string-to-number (match-string 5))) + (hour (string-to-number (match-string 4))) + (day (string-to-number (match-string 3))) + (year (string-to-number (match-string 7)))) + (if (equal mtime + (encode-time + second minute hour day + (/ (string-match + (match-string 2) + "xxxJanFebMarAprMayJunJulAugSepOctNovDec") + 3) + year 0)) (vc-file-setprop file 'vc-checkout-time mtime) (vc-file-setprop file 'vc-checkout-time 0))) (throw 'found (cons (concat dirname "CVS/Entries") 'CVS))) - (t (setq case-fold-search fold) ;; restore the old value - nil))) + ;; entry with arbitrary text as timestamp + ;; (this means we should consider it modified) + ((re-search-forward + (concat "^/" (regexp-quote basename) + ;; revision + "/\\([^/]*\\)" + ;; timestamp (arbitrary text) + "/[^/]*" + ;; optional conflict field + "\\(+[^/]*\\)?/") + nil t) + ;; We found it. Store away version number now that we + ;; are anyhow so close to finding it. + (vc-file-setprop file 'vc-workfile-version (match-string 1)) + (vc-file-setprop file 'vc-checkout-time 0) + (throw 'found (cons (concat dirname "CVS/Entries") 'CVS))) + (t nil))) (kill-buffer buffer))))) (defun vc-buffer-backend () @@ -830,9 +970,14 @@ For CVS, the full name of CVS/Entries is returned." "Change read-only status of current buffer, perhaps via version control. If the buffer is visiting a file registered with version control, then check the file in or out. Otherwise, just change the read-only flag -of the buffer. With prefix argument, ask for version number." +of the buffer. +With prefix argument, ask for version number to check in or check out. +Check-out of a specified version number does not lock the file; +to do that, use this command a second time with no argument." (interactive "P") - (if (vc-backend (buffer-file-name)) + (if (or (and (boundp 'vc-dired-mode) vc-dired-mode) + ;; use boundp because vc.el might not be loaded + (vc-backend (buffer-file-name))) (vc-next-action verbose) (toggle-read-only))) (define-key global-map "\C-x\C-q" 'vc-toggle-read-only) @@ -843,13 +988,7 @@ of the buffer. With prefix argument, ask for version number." ;; not locked, and the checkout model for it is `implicit', ;; mark it "locked" and redisplay the mode line. (let ((file (buffer-file-name))) - (and (vc-file-getprop file 'vc-backend) - ;; ...check the property directly, not through the function of the - ;; same name. Otherwise Emacs would check for a master file - ;; each time a non-version-controlled buffer is saved. - ;; The property is computed when the file is visited, so if it - ;; is `nil' now, it is certain that the file is NOT - ;; version-controlled. + (and (vc-backend file) (or (and (equal (vc-file-getprop file 'vc-checkout-time) (nth 5 (file-attributes file))) ;; File has been saved in the same second in which @@ -859,7 +998,7 @@ of the buffer. With prefix argument, ask for version number." t) (not (vc-locking-user file)) (eq (vc-checkout-model file) 'implicit) - (vc-file-setprop file 'vc-locking-user (user-login-name)) + (vc-file-setprop file 'vc-locking-user (vc-user-login-name)) (or (and (eq (vc-backend file) 'CVS) (vc-file-setprop file 'vc-cvs-status nil)) t) @@ -876,13 +1015,23 @@ control system name." (and vc-type (concat " " (or label (symbol-name vc-type)) (and vc-display-status (vc-status file))))) + ;; If the file is locked by some other user, make + ;; the buffer read-only. Like this, even root + ;; cannot modify a file that someone else has locked. (and vc-type (equal file (buffer-file-name)) (vc-locking-user file) - ;; If the file is locked by some other user, make - ;; the buffer read-only. Like this, even root - ;; cannot modify a file without locking it first. - (not (string= (user-login-name) (vc-locking-user file))) + (not (string= (vc-user-login-name) (vc-locking-user file))) + (setq buffer-read-only t)) + ;; If the user is root, and the file is not owner-writable, + ;; then pretend that we can't write it + ;; even though we can (because root can write anything). + ;; This way, even root cannot modify a file that isn't locked. + (and vc-type + (equal file (buffer-file-name)) + (not buffer-read-only) + (zerop (user-real-uid)) + (zerop (logand (file-modes (buffer-file-name)) 128)) (setq buffer-read-only t)) (force-mode-line-update) ;;(set-buffer-modified-p (buffer-modified-p)) ;;use this if Emacs 18 @@ -910,19 +1059,35 @@ control system name." " @@") ((not locker) (concat "-" rev)) - ((if (stringp locker) - (string= locker (user-login-name)) - (= locker (user-uid))) + ((string= locker (vc-user-login-name)) (concat ":" rev)) (t (concat ":" locker ":" rev))))) +(defun vc-follow-link () + ;; If the current buffer visits a symbolic link, this function makes it + ;; visit the real file instead. If the real file is already visited in + ;; another buffer, make that buffer current, and kill the buffer + ;; that visits the link. + (let* ((truename (abbreviate-file-name (file-chase-links buffer-file-name))) + (true-buffer (find-buffer-visiting truename)) + (this-buffer (current-buffer))) + (if (eq true-buffer this-buffer) + (progn + (kill-buffer this-buffer) + ;; In principle, we could do something like set-visited-file-name. + ;; However, it can't be exactly the same as set-visited-file-name. + ;; I'm not going to work out the details right now. -- rms. + (set-buffer (find-file-noselect truename))) + (set-buffer true-buffer) + (kill-buffer this-buffer)))) + ;;; install a call to the above as a find-file hook (defun vc-find-file-hook () ;; Recompute whether file is version controlled, ;; if user has killed the buffer and revisited. (cond - (buffer-file-name + ((and (not vc-ignore-vc-files) buffer-file-name) (vc-file-clearprops buffer-file-name) (cond ((vc-backend buffer-file-name) @@ -933,24 +1098,31 @@ control system name." (make-local-variable 'backup-inhibited) (setq backup-inhibited t)))) ((let* ((link (file-symlink-p buffer-file-name)) - (link-type (and link (vc-backend link)))) + (link-type (and link (vc-backend (file-chase-links link))))) (if link-type (cond ((eq vc-follow-symlinks nil) (message "Warning: symbolic link to %s-controlled source file" link-type)) - ((eq vc-follow-symlinks 'ask) + ((or (not (eq vc-follow-symlinks 'ask)) + ;; If we already visited this file by following + ;; the link, don't ask again if we try to visit + ;; it again. GUD does that, and repeated questions + ;; are painful. + (get-file-buffer + (abbreviate-file-name (file-chase-links buffer-file-name)))) + + (vc-follow-link) + (message "Followed link to %s" buffer-file-name) + (vc-find-file-hook)) + (t (if (yes-or-no-p (format "Symbolic link to %s-controlled source file; follow link? " link-type)) - (progn (setq buffer-file-name - (file-truename buffer-file-name)) + (progn (vc-follow-link) (message "Followed link to %s" buffer-file-name) (vc-find-file-hook)) (message "Warning: editing through the link bypasses version control") - )) - (t (setq buffer-file-name (file-truename buffer-file-name)) - (message "Followed link to %s" buffer-file-name) - (vc-find-file-hook)))))))))) + )))))))))) (add-hook 'find-file-hooks 'vc-find-file-hook) @@ -958,7 +1130,11 @@ control system name." (defun vc-file-not-found-hook () "When file is not found, try to check it out from RCS or SCCS. Returns t if checkout was successful, nil otherwise." - (if (vc-backend buffer-file-name) + ;; When a file does not exist, ignore cached info about it + ;; from a previous visit. + (vc-file-clearprops buffer-file-name) + (if (and (not vc-ignore-vc-files) + (vc-backend buffer-file-name)) (save-excursion (require 'vc) (setq default-directory (file-name-directory (buffer-file-name))) @@ -987,9 +1163,11 @@ Returns t if checkout was successful, nil otherwise." (define-key vc-prefix-map "a" 'vc-update-change-log) (define-key vc-prefix-map "c" 'vc-cancel-version) (define-key vc-prefix-map "d" 'vc-directory) + (define-key vc-prefix-map "g" 'vc-annotate) (define-key vc-prefix-map "h" 'vc-insert-headers) (define-key vc-prefix-map "i" 'vc-register) (define-key vc-prefix-map "l" 'vc-print-log) + (define-key vc-prefix-map "m" 'vc-merge) (define-key vc-prefix-map "r" 'vc-retrieve-snapshot) (define-key vc-prefix-map "s" 'vc-create-snapshot) (define-key vc-prefix-map "u" 'vc-revert-buffer) @@ -1003,8 +1181,13 @@ Returns t if checkout was successful, nil otherwise." () ;;(define-key vc-menu-map [show-files] ;; '("Show Files under VC" . (vc-directory t))) - (define-key vc-menu-map [vc-directory] '("Show Locked Files" . vc-directory)) + (define-key vc-menu-map [vc-retrieve-snapshot] + '("Retrieve Snapshot" . vc-retrieve-snapshot)) + (define-key vc-menu-map [vc-create-snapshot] + '("Create Snapshot" . vc-create-snapshot)) + (define-key vc-menu-map [vc-directory] '("VC Directory Listing" . vc-directory)) (define-key vc-menu-map [separator1] '("----")) + (define-key vc-menu-map [vc-annotate] '("Annotate" . vc-annotate)) (define-key vc-menu-map [vc-rename-file] '("Rename File" . vc-rename-file)) (define-key vc-menu-map [vc-version-other-window] '("Show Other Version" . vc-version-other-window)) @@ -1018,22 +1201,25 @@ Returns t if checkout was successful, nil otherwise." '("Revert to Last Version" . vc-revert-buffer)) (define-key vc-menu-map [vc-insert-header] '("Insert Header" . vc-insert-headers)) - (define-key vc-menu-map [vc-menu-check-in] '("Check In" . vc-next-action)) - (define-key vc-menu-map [vc-check-out] '("Check Out" . vc-toggle-read-only)) - (define-key vc-menu-map [vc-register] '("Register" . vc-register)) - (put 'vc-rename-file 'menu-enable 'vc-mode) - (put 'vc-version-other-window 'menu-enable 'vc-mode) - (put 'vc-diff 'menu-enable 'vc-mode) - (put 'vc-update-change-log 'menu-enable - '(eq (vc-buffer-backend) 'RCS)) - (put 'vc-print-log 'menu-enable 'vc-mode) - (put 'vc-cancel-version 'menu-enable 'vc-mode) - (put 'vc-revert-buffer 'menu-enable 'vc-mode) - (put 'vc-insert-headers 'menu-enable 'vc-mode) - (put 'vc-next-action 'menu-enable '(and vc-mode (not buffer-read-only))) - (put 'vc-toggle-read-only 'menu-enable '(and vc-mode buffer-read-only)) - (put 'vc-register 'menu-enable '(and buffer-file-name (not vc-mode))) - ) + (define-key vc-menu-map [vc-next-action] '("Check In/Out" . vc-next-action)) + (define-key vc-menu-map [vc-register] '("Register" . vc-register))) + +;;; These are not correct and it's not currently clear how doing it +;;; better (with more complicated expressions) might slow things down +;;; on older systems. + +;;;(put 'vc-rename-file 'menu-enable 'vc-mode) +;;;(put 'vc-annotate 'menu-enable '(eq (vc-buffer-backend) 'CVS)) +;;;(put 'vc-version-other-window 'menu-enable 'vc-mode) +;;;(put 'vc-diff 'menu-enable 'vc-mode) +;;;(put 'vc-update-change-log 'menu-enable +;;; '(eq (vc-buffer-backend) 'RCS)) +;;;(put 'vc-print-log 'menu-enable 'vc-mode) +;;;(put 'vc-cancel-version 'menu-enable 'vc-mode) +;;;(put 'vc-revert-buffer 'menu-enable 'vc-mode) +;;;(put 'vc-insert-headers 'menu-enable 'vc-mode) +;;;(put 'vc-next-action 'menu-enable 'vc-mode) +;;;(put 'vc-register 'menu-enable '(and buffer-file-name (not vc-mode))) (provide 'vc-hooks)