emacs: lisp/vc-hooks.el comparison

comparison lisp/vc-hooks.el @ 12925:77c9a594fe55

(vc-simple-command): New function. (vc-fetch-master-properties): CVS case: Use it. (vc-lock-from-permissions, vc-file-owner, vc-rcs-lock-from-diff): New functions. (vc-locking-user): Largely rewritten. Uses the above, handles RCS non-strict locking. Under CVS in CVSREAD-mode, learn the locking state from the permissions. (vc-find-cvs-master): Use vc-insert-file, rather than find-file-noselect. Greatly speeds up things. (vc-consult-rcs-headers): Bug fix, return status in all cases.

author	André Spiegel <spiegel@gnu.org>
date	Tue, 22 Aug 1995 17:52:42 +0000
parents	22f47b2375c1
children	b10874fddeb3

comparison

equal deleted inserted replaced

-:8172973fd6e4
+:77c9a594fe55
 	     (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
 			 file '(vc-master-workfile-version)))))
 ;; translate the locks
 (vc-parse-locks file (vc-file-getprop file 'vc-master-locks)))
 ((eq (vc-backend file) 'CVS)
-;; don't switch to the *vc-info* buffer before running the
+(save-excursion
-;; command, because that would change its default directory
+	(vc-simple-command 0 "cvs" file "status")
-(save-excursion (set-buffer (get-buffer-create "*vc-info*"))
+	(set-buffer (get-buffer "*vc-info*"))
-		      (erase-buffer))
+	(vc-parse-buffer
-(let ((exec-path (append vc-path exec-path)) exec-status
+	 ;; CVS 1.3 says "RCS Version:", other releases "RCS Revision:",
-	    ;; Add vc-path to PATH for the execution of this command.
+	 ;; and CVS 1.4a1 says "Repository revision:".
-	    (process-environment
+	 '(("\\(RCS Version\\|RCS Revision\\|Repository revision\\):[\t ]+\\([0-9.]+\\)" 2)
-	     (cons (concat "PATH=" (getenv "PATH")
+	   ("^File: [^ \t]+[ \t]+Status: \\(.*\\)" 1))
-			   path-separator
+	 file
-			   (mapconcat 'identity vc-path path-separator))
+	 '(vc-latest-version vc-cvs-status))
-		   process-environment)))
+	;; Translate those status values that we understand into symbols.
-	(setq exec-status
+	;; Any other value is converted to nil.
-	      (apply 'call-process "cvs" nil "*vc-info*" nil
+	(let ((status (vc-file-getprop file 'vc-cvs-status)))
-		     (list "status" file)))
+	 (cond
-	(cond ((> exec-status 0)
+	  ((string-match "Up-to-date" status)
-	       (switch-to-buffer (get-file-buffer file))
+	   (vc-file-setprop file 'vc-cvs-status 'up-to-date)
-	       (shrink-window-if-larger-than-buffer
+	   (vc-file-setprop file 'vc-checkout-time
-		(display-buffer "*vc-info*"))
+			    (nth 5 (file-attributes file))))
-	       (error "Couldn't find version control information"))))
+	  ((vc-file-setprop file 'vc-cvs-status
-(set-buffer (get-buffer "*vc-info*"))
-(set-buffer-modified-p nil)
-(auto-save-mode nil)
-(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 are needed 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"      status) 'needs-checkout)
 	     ((string-match "Unresolved Conflict" status) 'unresolved-conflict)
 	     ((string-match "Locally Added"       status) 'locally-added)
-	     )))))))
+	     ))))))))
 (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
 	  ;; `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))
+	    (vc-file-setprop file 'vc-checkout-model 'implicit)))
-	  status)))))
+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
 ;; search for a lock on the current workfile version
 (setq lock (assoc (vc-workfile-version file) master-locks))
 (cond (lock (cdr lock))
 	    ('none)))))
+(defun vc-lock-from-permissions (file)
+;; If the permissions can be trusted for this file, determine the
+;; locking state from them.  Returns (user-login-name), `none', or nil.
+;;   This implementation assumes that any file which is under version
+;; control and has -rw-r--r-- is locked by its owner.  This is true
+;; for both RCS and SCCS, which keep unlocked files at -r--r--r--.
+;; We have to be careful not to exclude files with execute bits on;
+;; scripts can be under version control too.  Also, we must ignore the
+;; group-read and other-read bits, since paranoid users turn them off.
+;;   This hack wins because calls to the somewhat expensive
+;; `vc-fetch-master-properties' function only have to be made if
+;; (a) the file is locked by someone other than the current user,
+;; or (b) some untoward manipulation behind vc's back has changed
+;; the owner or the `group' or `other' write bits.
+(let ((attributes (file-attributes file)))
+(if (not (vc-mistrust-permissions file))
+	(cond ((string-match ".r-..-..-." (nth 8 attributes))
+	       (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)))
+	      (nil)))))
+(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)))
+(defun vc-rcs-lock-from-diff (file)
+;; Diff the file against the master version.  If differences are found,
+;; mark the file locked.  This is only meaningful for RCS with non-strict
+;; locking.
+(if (zerop (vc-simple-command 1 "rcsdiff" file
+	       "--brief"  ; Some diffs don't understand "--brief", but
+	                  ; for non-strict locking under VC we require it.
+	       (concat "-r" (vc-workfile-version file))))
+(vc-file-setprop file 'vc-locking-user 'none)
+(vc-file-setprop file 'vc-locking-user (vc-file-owner file))))
 (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.
+;; Return nil if there is no such person.  (Sometimes, not the name
+;; of the locking user but his uid will be returned.)
 ;;   Under CVS, a file is considered locked if it has been modified since
-;; it was checked out.  Under CVS, this will sometimes return the uid of
+;; it was checked out.
-;; the owner of the file (as a number) instead of a string.
 ;;   The property is cached.  It is only looked up if it is currently nil.
 ;; Note that, for a file that is not locked, the actual property value
-;; is 'none, to distinguish it from an unknown locking state.  That value
+;; is `none', to distinguish it from an unknown locking state.  That value
 ;; is converted to nil by this function, and returned to the caller.
 (let ((locking-user (vc-file-getprop file 'vc-locking-user)))
 (if locking-user
 	;; if we already know the property, return it
 	(if (eq locking-user 'none) nil locking-user)
 ;; otherwise, infer the property...
 (cond
-;; in the CVS case, check the status
 ((eq (vc-backend file) 'CVS)
-	(if (or (eq (vc-cvs-status file) 'up-to-date)
+	(or (and (eq (vc-checkout-model file) 'manual)
-		(eq (vc-cvs-status file) 'needs-checkout))
+		 (vc-lock-from-permissions file))
-	    (vc-file-setprop file 'vc-locking-user 'none)
+	    (if (or (eq (vc-cvs-status file) 'up-to-date)
-	  ;; The expression below should return the username of the owner
+		    (eq (vc-cvs-status file) 'needs-checkout))
-	  ;; of the file.  It doesn't.  It returns the username if it is
+		(vc-file-setprop file 'vc-locking-user 'none)
-	  ;; you, or otherwise the UID of the owner of the file.  The
+	      (vc-file-setprop file 'vc-locking-user (vc-file-owner file)))))
-	  ;; return value from this function is only used by
-	  ;; vc-dired-reformat-line, and it does the proper thing if a UID
+((eq (vc-backend file) 'RCS)
-	  ;; is returned.
+	(let (p-lock)
-	  ;;
-	  ;; The *proper* way to fix this would be to implement a built-in
+	  ;; Check for RCS headers first
-	  ;; function in Emacs, say, (username UID), that returns the
+	  (or (eq (vc-consult-rcs-headers file) 'rev-and-lock)
-	  ;; username of a given UID.
-	  ;;
+	      ;; If there are no headers, try to learn it
-	  ;; The result of this hack is that vc-directory will print the
+	      ;; from the permissions.
-	  ;; name of the owner of the file for any files that are
+	      (and (setq p-lock (vc-lock-from-permissions file))
-	  ;; modified.
+		   (if (eq p-lock 'none)
-	  (let ((uid (nth 2 (file-attributes file))))
-	    (if (= uid (user-uid))
+		       ;; If the permissions say "not locked", we know
-		(vc-file-setprop file 'vc-locking-user (user-login-name))
+		       ;; that the checkout model must be `manual'.
-	      (vc-file-setprop file 'vc-locking-user uid)))))
+		       (vc-file-setprop file 'vc-checkout-model 'manual)
-;; RCS case: attempt a header search. If this feature is
+		     ;; If the permissions say "locked", we can only trust
-;; disabled, vc-consult-rcs-headers always returns nil.
+		     ;; this *if* the checkout model is `manual'.
-((and (eq (vc-backend file) 'RCS)
+		     (eq (vc-checkout-model file) 'manual)))
-	     (eq (vc-consult-rcs-headers file) 'rev-and-lock)))
+	      ;; Otherwise, use lock information from the master file.
-;; if the file permissions are not trusted,
+	      (vc-file-setprop file 'vc-locking-user
-;; or if locking is not strict,
+			       (vc-master-locking-user file)))
-;; use the information from the master file
-((or (not vc-keep-workfiles)
+	  ;; Finally, if the file is not explicitly locked
-	    (vc-mistrust-permissions file)
+	  ;; it might still be locked implicitly.
-	    (eq (vc-checkout-model file) 'implicit))
+	  (and (eq (vc-file-getprop file 'vc-locking-user) 'none)
-	(vc-file-setprop file 'vc-locking-user (vc-master-locking-user file)))
+	       (eq (vc-checkout-model file) 'implicit)
+	       (vc-rcs-lock-from-diff file))))
-;; Otherwise: Use the file permissions. (But if it turns out that the
-;; file is not owned by the user, use the master file.)
+((eq (vc-backend file) 'SCCS)
-;;   This implementation assumes that any file which is under version
+(or (vc-lock-from-permissions file)
-;; control and has -rw-r--r-- is locked by its owner.  This is true
+	   (vc-file-setprop file 'vc-locking-user
-;; for both RCS and SCCS, which keep unlocked files at -r--r--r--.
+			    (vc-master-locking-user file))))))
-;; We have to be careful not to exclude files with execute bits on;
-;; scripts can be under version control too.  Also, we must ignore the
+;; convert a possible 'none value
-;; group-read and other-read bits, since paranoid users turn them off.
+(setq locking-user (vc-file-getprop file 'vc-locking-user))
-;;   This hack wins because calls to the somewhat expensive
+(if (eq locking-user 'none) nil locking-user)))
-;; `vc-fetch-master-properties' function only have to be made if
-;; (a) the file is locked by someone other than the current user,
-;; or (b) some untoward manipulation behind vc's back has changed
-;; the owner or the `group' or `other' write bits.
-(t
-(let ((attributes (file-attributes file)))
-	(cond ((string-match ".r-..-..-." (nth 8 attributes))
-	       (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)))
-	      (t
-	       (vc-file-setprop file 'vc-locking-user
-				(vc-master-locking-user file))))
-	)))
-;; recursively call the function again,
-;; to convert a possible 'none value
-(vc-locking-user file))))
 ;;; properties to store current and recent version numbers
 (defun vc-latest-version (file)
 ;; Return version level of the latest version of FILE
 ;; DIRNAME/BASENAME is not handled by CVS.
 (if (and vc-handle-cvs
 	   (file-directory-p (concat dirname "CVS/"))
 	   (file-readable-p (concat dirname "CVS/Entries"))
 	   (file-readable-p (concat dirname "CVS/Repository")))
-(let ((bufs nil) (fold case-fold-search))
+(let (buffer (fold case-fold-search))
 	(unwind-protect
 	    (save-excursion
-	      (setq bufs (list
+	      (setq buffer (set-buffer (get-buffer-create "*vc-info*")))
-			  (find-file-noselect (concat dirname "CVS/Entries"))))
+	      (vc-insert-file (concat dirname "CVS/Entries"))
-	      (set-buffer (car bufs))
 	      (goto-char (point-min))
 	      ;; make sure the file name is searched
 	      ;; case-sensitively
 	      (setq case-fold-search nil)
 	      (cond
 		;; that we are anyhow so close to finding it.
 		(vc-file-setprop (concat dirname basename)
 				 'vc-workfile-version
 				 (buffer-substring (match-beginning 1)
 						   (match-end 1)))
-		(setq bufs (cons (find-file-noselect
+		(vc-insert-file (concat dirname "CVS/Repository"))
-				  (concat dirname "CVS/Repository"))
-				 bufs))
-		(set-buffer (car bufs))
 		(let ((master
 		       (concat (file-name-as-directory
 				(buffer-substring (point-min)
 						  (1- (point-max))))
 			       basename
 			       ",v")))
 		  (throw 'found (cons master 'CVS))))
 	       (t (setq case-fold-search fold)  ;; restore the old value
 		  nil)))
-	  (mapcar (function kill-buffer) bufs)))))
+	  (kill-buffer buffer)))))
 (defun vc-buffer-backend ()
 "Return the version-control type of the visited file, or nil if none."
 (if (eq vc-buffer-backend t)
 (setq vc-buffer-backend (vc-backend (buffer-file-name)))

Mercurial > emacs

comparison lisp/vc-hooks.el @ 12925:77c9a594fe55