Mercurial > emacs
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
12924:8172973fd6e4 | 12925:77c9a594fe55 |
---|---|
229 (if (string-match ";[ \t\n]+strict;" locks index) | 229 (if (string-match ";[ \t\n]+strict;" locks index) |
230 (vc-file-setprop file 'vc-checkout-model 'manual) | 230 (vc-file-setprop file 'vc-checkout-model 'manual) |
231 (vc-file-setprop file 'vc-checkout-model 'implicit)))) | 231 (vc-file-setprop file 'vc-checkout-model 'implicit)))) |
232 (vc-file-setprop file 'vc-master-locks (or master-locks 'none))))) | 232 (vc-file-setprop file 'vc-master-locks (or master-locks 'none))))) |
233 | 233 |
234 (defun vc-simple-command (okstatus command file &rest args) | |
235 ;; Simple version of vc-do-command, for use in vc-hooks only. | |
236 ;; Don't switch to the *vc-info* buffer before running the | |
237 ;; command, because that would change its default directory | |
238 (save-excursion (set-buffer (get-buffer-create "*vc-info*")) | |
239 (erase-buffer)) | |
240 (let ((exec-path (append vc-path exec-path)) exec-status | |
241 ;; Add vc-path to PATH for the execution of this command. | |
242 (process-environment | |
243 (cons (concat "PATH=" (getenv "PATH") | |
244 path-separator | |
245 (mapconcat 'identity vc-path path-separator)) | |
246 process-environment))) | |
247 (setq exec-status | |
248 (apply 'call-process command nil "*vc-info*" nil | |
249 (append args (list file)))) | |
250 (cond ((> exec-status okstatus) | |
251 (switch-to-buffer (get-file-buffer file)) | |
252 (shrink-window-if-larger-than-buffer | |
253 (display-buffer "*vc-info*")) | |
254 (error "Couldn't find version control information"))) | |
255 exec-status)) | |
256 | |
234 (defun vc-fetch-master-properties (file) | 257 (defun vc-fetch-master-properties (file) |
235 ;; Fetch those properties of FILE that are stored in the master file. | 258 ;; Fetch those properties of FILE that are stored in the master file. |
236 ;; For an RCS file, we don't get vc-latest-version vc-your-latest-version | 259 ;; For an RCS file, we don't get vc-latest-version vc-your-latest-version |
237 ;; here because that is slow. | 260 ;; here because that is slow. |
238 ;; That gets done if/when the functions vc-latest-version | 261 ;; That gets done if/when the functions vc-latest-version |
285 file '(vc-master-workfile-version))))) | 308 file '(vc-master-workfile-version))))) |
286 ;; translate the locks | 309 ;; translate the locks |
287 (vc-parse-locks file (vc-file-getprop file 'vc-master-locks))) | 310 (vc-parse-locks file (vc-file-getprop file 'vc-master-locks))) |
288 | 311 |
289 ((eq (vc-backend file) 'CVS) | 312 ((eq (vc-backend file) 'CVS) |
290 ;; don't switch to the *vc-info* buffer before running the | 313 (save-excursion |
291 ;; command, because that would change its default directory | 314 (vc-simple-command 0 "cvs" file "status") |
292 (save-excursion (set-buffer (get-buffer-create "*vc-info*")) | 315 (set-buffer (get-buffer "*vc-info*")) |
293 (erase-buffer)) | 316 (vc-parse-buffer |
294 (let ((exec-path (append vc-path exec-path)) exec-status | 317 ;; CVS 1.3 says "RCS Version:", other releases "RCS Revision:", |
295 ;; Add vc-path to PATH for the execution of this command. | 318 ;; and CVS 1.4a1 says "Repository revision:". |
296 (process-environment | 319 '(("\\(RCS Version\\|RCS Revision\\|Repository revision\\):[\t ]+\\([0-9.]+\\)" 2) |
297 (cons (concat "PATH=" (getenv "PATH") | 320 ("^File: [^ \t]+[ \t]+Status: \\(.*\\)" 1)) |
298 path-separator | 321 file |
299 (mapconcat 'identity vc-path path-separator)) | 322 '(vc-latest-version vc-cvs-status)) |
300 process-environment))) | 323 ;; Translate those status values that we understand into symbols. |
301 (setq exec-status | 324 ;; Any other value is converted to nil. |
302 (apply 'call-process "cvs" nil "*vc-info*" nil | 325 (let ((status (vc-file-getprop file 'vc-cvs-status))) |
303 (list "status" file))) | 326 (cond |
304 (cond ((> exec-status 0) | 327 ((string-match "Up-to-date" status) |
305 (switch-to-buffer (get-file-buffer file)) | 328 (vc-file-setprop file 'vc-cvs-status 'up-to-date) |
306 (shrink-window-if-larger-than-buffer | 329 (vc-file-setprop file 'vc-checkout-time |
307 (display-buffer "*vc-info*")) | 330 (nth 5 (file-attributes file)))) |
308 (error "Couldn't find version control information")))) | 331 ((vc-file-setprop file 'vc-cvs-status |
309 (set-buffer (get-buffer "*vc-info*")) | |
310 (set-buffer-modified-p nil) | |
311 (auto-save-mode nil) | |
312 (vc-parse-buffer | |
313 ;; CVS 1.3 says "RCS Version:", other releases "RCS Revision:", | |
314 ;; and CVS 1.4a1 says "Repository revision:". | |
315 '(("\\(RCS Version\\|RCS Revision\\|Repository revision\\):[\t ]+\\([0-9.]+\\)" 2) | |
316 ("^File: [^ \t]+[ \t]+Status: \\(.*\\)" 1)) | |
317 file | |
318 '(vc-latest-version vc-cvs-status)) | |
319 ;; Translate those status values that are needed into symbols. | |
320 ;; Any other value is converted to nil. | |
321 (let ((status (vc-file-getprop file 'vc-cvs-status))) | |
322 (cond | |
323 ((string-match "Up-to-date" status) | |
324 (vc-file-setprop file 'vc-cvs-status 'up-to-date) | |
325 (vc-file-setprop file 'vc-checkout-time | |
326 (nth 5 (file-attributes file)))) | |
327 ((vc-file-setprop file 'vc-cvs-status | |
328 (cond | 332 (cond |
329 ((string-match "Locally Modified" status) 'locally-modified) | 333 ((string-match "Locally Modified" status) 'locally-modified) |
330 ((string-match "Needs Merge" status) 'needs-merge) | 334 ((string-match "Needs Merge" status) 'needs-merge) |
331 ((string-match "Needs Checkout" status) 'needs-checkout) | 335 ((string-match "Needs Checkout" status) 'needs-checkout) |
332 ((string-match "Unresolved Conflict" status) 'unresolved-conflict) | 336 ((string-match "Unresolved Conflict" status) 'unresolved-conflict) |
333 ((string-match "Locally Added" status) 'locally-added) | 337 ((string-match "Locally Added" status) 'locally-added) |
334 ))))))) | 338 )))))))) |
335 (if (get-buffer "*vc-info*") | 339 (if (get-buffer "*vc-info*") |
336 (kill-buffer (get-buffer "*vc-info*"))))) | 340 (kill-buffer (get-buffer "*vc-info*"))))) |
337 | 341 |
338 ;;; Functions that determine property values, by examining the | 342 ;;; Functions that determine property values, by examining the |
339 ;;; working file, the master file, or log program output | 343 ;;; working file, the master file, or log program output |
424 ;; `manual', otherwise `implicit'. | 428 ;; `manual', otherwise `implicit'. |
425 (not (vc-mistrust-permissions file)) | 429 (not (vc-mistrust-permissions file)) |
426 (not (vc-locking-user file)) | 430 (not (vc-locking-user file)) |
427 (if (string-match ".r-..-..-." (nth 8 (file-attributes file))) | 431 (if (string-match ".r-..-..-." (nth 8 (file-attributes file))) |
428 (vc-file-setprop file 'vc-checkout-model 'manual) | 432 (vc-file-setprop file 'vc-checkout-model 'manual) |
429 (vc-file-setprop file 'vc-checkout-model 'implicit)) | 433 (vc-file-setprop file 'vc-checkout-model 'implicit))) |
430 status))))) | 434 status)))) |
431 | 435 |
432 ;;; Access functions to file properties | 436 ;;; Access functions to file properties |
433 ;;; (Properties should be _set_ using vc-file-setprop, but | 437 ;;; (Properties should be _set_ using vc-file-setprop, but |
434 ;;; _retrieved_ only through these functions, which decide | 438 ;;; _retrieved_ only through these functions, which decide |
435 ;;; if the property is already known or not. A property should | 439 ;;; if the property is already known or not. A property should |
509 ;; search for a lock on the current workfile version | 513 ;; search for a lock on the current workfile version |
510 (setq lock (assoc (vc-workfile-version file) master-locks)) | 514 (setq lock (assoc (vc-workfile-version file) master-locks)) |
511 (cond (lock (cdr lock)) | 515 (cond (lock (cdr lock)) |
512 ('none))))) | 516 ('none))))) |
513 | 517 |
518 (defun vc-lock-from-permissions (file) | |
519 ;; If the permissions can be trusted for this file, determine the | |
520 ;; locking state from them. Returns (user-login-name), `none', or nil. | |
521 ;; This implementation assumes that any file which is under version | |
522 ;; control and has -rw-r--r-- is locked by its owner. This is true | |
523 ;; for both RCS and SCCS, which keep unlocked files at -r--r--r--. | |
524 ;; We have to be careful not to exclude files with execute bits on; | |
525 ;; scripts can be under version control too. Also, we must ignore the | |
526 ;; group-read and other-read bits, since paranoid users turn them off. | |
527 ;; This hack wins because calls to the somewhat expensive | |
528 ;; `vc-fetch-master-properties' function only have to be made if | |
529 ;; (a) the file is locked by someone other than the current user, | |
530 ;; or (b) some untoward manipulation behind vc's back has changed | |
531 ;; the owner or the `group' or `other' write bits. | |
532 (let ((attributes (file-attributes file))) | |
533 (if (not (vc-mistrust-permissions file)) | |
534 (cond ((string-match ".r-..-..-." (nth 8 attributes)) | |
535 (vc-file-setprop file 'vc-locking-user 'none)) | |
536 ((and (= (nth 2 attributes) (user-uid)) | |
537 (string-match ".rw..-..-." (nth 8 attributes))) | |
538 (vc-file-setprop file 'vc-locking-user (user-login-name))) | |
539 (nil))))) | |
540 | |
541 (defun vc-file-owner (file) | |
542 ;; The expression below should return the username of the owner | |
543 ;; of the file. It doesn't. It returns the username if it is | |
544 ;; you, or otherwise the UID of the owner of the file. The | |
545 ;; return value from this function is only used by | |
546 ;; vc-dired-reformat-line, and it does the proper thing if a UID | |
547 ;; is returned. | |
548 ;; The *proper* way to fix this would be to implement a built-in | |
549 ;; function in Emacs, say, (username UID), that returns the | |
550 ;; username of a given UID. | |
551 ;; The result of this hack is that vc-directory will print the | |
552 ;; name of the owner of the file for any files that are | |
553 ;; modified. | |
554 (let ((uid (nth 2 (file-attributes file)))) | |
555 (if (= uid (user-uid)) (user-login-name) uid))) | |
556 | |
557 (defun vc-rcs-lock-from-diff (file) | |
558 ;; Diff the file against the master version. If differences are found, | |
559 ;; mark the file locked. This is only meaningful for RCS with non-strict | |
560 ;; locking. | |
561 (if (zerop (vc-simple-command 1 "rcsdiff" file | |
562 "--brief" ; Some diffs don't understand "--brief", but | |
563 ; for non-strict locking under VC we require it. | |
564 (concat "-r" (vc-workfile-version file)))) | |
565 (vc-file-setprop file 'vc-locking-user 'none) | |
566 (vc-file-setprop file 'vc-locking-user (vc-file-owner file)))) | |
567 | |
514 (defun vc-locking-user (file) | 568 (defun vc-locking-user (file) |
515 ;; Return the name of the person currently holding a lock on FILE. | 569 ;; Return the name of the person currently holding a lock on FILE. |
516 ;; Return nil if there is no such person. | 570 ;; Return nil if there is no such person. (Sometimes, not the name |
571 ;; of the locking user but his uid will be returned.) | |
517 ;; Under CVS, a file is considered locked if it has been modified since | 572 ;; Under CVS, a file is considered locked if it has been modified since |
518 ;; it was checked out. Under CVS, this will sometimes return the uid of | 573 ;; it was checked out. |
519 ;; the owner of the file (as a number) instead of a string. | |
520 ;; The property is cached. It is only looked up if it is currently nil. | 574 ;; The property is cached. It is only looked up if it is currently nil. |
521 ;; Note that, for a file that is not locked, the actual property value | 575 ;; Note that, for a file that is not locked, the actual property value |
522 ;; is 'none, to distinguish it from an unknown locking state. That value | 576 ;; is `none', to distinguish it from an unknown locking state. That value |
523 ;; is converted to nil by this function, and returned to the caller. | 577 ;; is converted to nil by this function, and returned to the caller. |
524 (let ((locking-user (vc-file-getprop file 'vc-locking-user))) | 578 (let ((locking-user (vc-file-getprop file 'vc-locking-user))) |
525 (if locking-user | 579 (if locking-user |
526 ;; if we already know the property, return it | 580 ;; if we already know the property, return it |
527 (if (eq locking-user 'none) nil locking-user) | 581 (if (eq locking-user 'none) nil locking-user) |
528 | 582 |
529 ;; otherwise, infer the property... | 583 ;; otherwise, infer the property... |
530 (cond | 584 (cond |
531 ;; in the CVS case, check the status | |
532 ((eq (vc-backend file) 'CVS) | 585 ((eq (vc-backend file) 'CVS) |
533 (if (or (eq (vc-cvs-status file) 'up-to-date) | 586 (or (and (eq (vc-checkout-model file) 'manual) |
534 (eq (vc-cvs-status file) 'needs-checkout)) | 587 (vc-lock-from-permissions file)) |
535 (vc-file-setprop file 'vc-locking-user 'none) | 588 (if (or (eq (vc-cvs-status file) 'up-to-date) |
536 ;; The expression below should return the username of the owner | 589 (eq (vc-cvs-status file) 'needs-checkout)) |
537 ;; of the file. It doesn't. It returns the username if it is | 590 (vc-file-setprop file 'vc-locking-user 'none) |
538 ;; you, or otherwise the UID of the owner of the file. The | 591 (vc-file-setprop file 'vc-locking-user (vc-file-owner file))))) |
539 ;; return value from this function is only used by | 592 |
540 ;; vc-dired-reformat-line, and it does the proper thing if a UID | 593 ((eq (vc-backend file) 'RCS) |
541 ;; is returned. | 594 (let (p-lock) |
542 ;; | 595 |
543 ;; The *proper* way to fix this would be to implement a built-in | 596 ;; Check for RCS headers first |
544 ;; function in Emacs, say, (username UID), that returns the | 597 (or (eq (vc-consult-rcs-headers file) 'rev-and-lock) |
545 ;; username of a given UID. | 598 |
546 ;; | 599 ;; If there are no headers, try to learn it |
547 ;; The result of this hack is that vc-directory will print the | 600 ;; from the permissions. |
548 ;; name of the owner of the file for any files that are | 601 (and (setq p-lock (vc-lock-from-permissions file)) |
549 ;; modified. | 602 (if (eq p-lock 'none) |
550 (let ((uid (nth 2 (file-attributes file)))) | 603 |
551 (if (= uid (user-uid)) | 604 ;; If the permissions say "not locked", we know |
552 (vc-file-setprop file 'vc-locking-user (user-login-name)) | 605 ;; that the checkout model must be `manual'. |
553 (vc-file-setprop file 'vc-locking-user uid))))) | 606 (vc-file-setprop file 'vc-checkout-model 'manual) |
554 | 607 |
555 ;; RCS case: attempt a header search. If this feature is | 608 ;; If the permissions say "locked", we can only trust |
556 ;; disabled, vc-consult-rcs-headers always returns nil. | 609 ;; this *if* the checkout model is `manual'. |
557 ((and (eq (vc-backend file) 'RCS) | 610 (eq (vc-checkout-model file) 'manual))) |
558 (eq (vc-consult-rcs-headers file) 'rev-and-lock))) | 611 |
559 | 612 ;; Otherwise, use lock information from the master file. |
560 ;; if the file permissions are not trusted, | 613 (vc-file-setprop file 'vc-locking-user |
561 ;; or if locking is not strict, | 614 (vc-master-locking-user file))) |
562 ;; use the information from the master file | 615 |
563 ((or (not vc-keep-workfiles) | 616 ;; Finally, if the file is not explicitly locked |
564 (vc-mistrust-permissions file) | 617 ;; it might still be locked implicitly. |
565 (eq (vc-checkout-model file) 'implicit)) | 618 (and (eq (vc-file-getprop file 'vc-locking-user) 'none) |
566 (vc-file-setprop file 'vc-locking-user (vc-master-locking-user file))) | 619 (eq (vc-checkout-model file) 'implicit) |
567 | 620 (vc-rcs-lock-from-diff file)))) |
568 ;; Otherwise: Use the file permissions. (But if it turns out that the | 621 |
569 ;; file is not owned by the user, use the master file.) | 622 ((eq (vc-backend file) 'SCCS) |
570 ;; This implementation assumes that any file which is under version | 623 (or (vc-lock-from-permissions file) |
571 ;; control and has -rw-r--r-- is locked by its owner. This is true | 624 (vc-file-setprop file 'vc-locking-user |
572 ;; for both RCS and SCCS, which keep unlocked files at -r--r--r--. | 625 (vc-master-locking-user file)))))) |
573 ;; We have to be careful not to exclude files with execute bits on; | 626 |
574 ;; scripts can be under version control too. Also, we must ignore the | 627 ;; convert a possible 'none value |
575 ;; group-read and other-read bits, since paranoid users turn them off. | 628 (setq locking-user (vc-file-getprop file 'vc-locking-user)) |
576 ;; This hack wins because calls to the somewhat expensive | 629 (if (eq locking-user 'none) nil locking-user))) |
577 ;; `vc-fetch-master-properties' function only have to be made if | |
578 ;; (a) the file is locked by someone other than the current user, | |
579 ;; or (b) some untoward manipulation behind vc's back has changed | |
580 ;; the owner or the `group' or `other' write bits. | |
581 (t | |
582 (let ((attributes (file-attributes file))) | |
583 (cond ((string-match ".r-..-..-." (nth 8 attributes)) | |
584 (vc-file-setprop file 'vc-locking-user 'none)) | |
585 ((and (= (nth 2 attributes) (user-uid)) | |
586 (string-match ".rw..-..-." (nth 8 attributes))) | |
587 (vc-file-setprop file 'vc-locking-user (user-login-name))) | |
588 (t | |
589 (vc-file-setprop file 'vc-locking-user | |
590 (vc-master-locking-user file)))) | |
591 ))) | |
592 ;; recursively call the function again, | |
593 ;; to convert a possible 'none value | |
594 (vc-locking-user file)))) | |
595 | 630 |
596 ;;; properties to store current and recent version numbers | 631 ;;; properties to store current and recent version numbers |
597 | 632 |
598 (defun vc-latest-version (file) | 633 (defun vc-latest-version (file) |
599 ;; Return version level of the latest version of FILE | 634 ;; Return version level of the latest version of FILE |
702 ;; DIRNAME/BASENAME is not handled by CVS. | 737 ;; DIRNAME/BASENAME is not handled by CVS. |
703 (if (and vc-handle-cvs | 738 (if (and vc-handle-cvs |
704 (file-directory-p (concat dirname "CVS/")) | 739 (file-directory-p (concat dirname "CVS/")) |
705 (file-readable-p (concat dirname "CVS/Entries")) | 740 (file-readable-p (concat dirname "CVS/Entries")) |
706 (file-readable-p (concat dirname "CVS/Repository"))) | 741 (file-readable-p (concat dirname "CVS/Repository"))) |
707 (let ((bufs nil) (fold case-fold-search)) | 742 (let (buffer (fold case-fold-search)) |
708 (unwind-protect | 743 (unwind-protect |
709 (save-excursion | 744 (save-excursion |
710 (setq bufs (list | 745 (setq buffer (set-buffer (get-buffer-create "*vc-info*"))) |
711 (find-file-noselect (concat dirname "CVS/Entries")))) | 746 (vc-insert-file (concat dirname "CVS/Entries")) |
712 (set-buffer (car bufs)) | |
713 (goto-char (point-min)) | 747 (goto-char (point-min)) |
714 ;; make sure the file name is searched | 748 ;; make sure the file name is searched |
715 ;; case-sensitively | 749 ;; case-sensitively |
716 (setq case-fold-search nil) | 750 (setq case-fold-search nil) |
717 (cond | 751 (cond |
723 ;; that we are anyhow so close to finding it. | 757 ;; that we are anyhow so close to finding it. |
724 (vc-file-setprop (concat dirname basename) | 758 (vc-file-setprop (concat dirname basename) |
725 'vc-workfile-version | 759 'vc-workfile-version |
726 (buffer-substring (match-beginning 1) | 760 (buffer-substring (match-beginning 1) |
727 (match-end 1))) | 761 (match-end 1))) |
728 (setq bufs (cons (find-file-noselect | 762 (vc-insert-file (concat dirname "CVS/Repository")) |
729 (concat dirname "CVS/Repository")) | |
730 bufs)) | |
731 (set-buffer (car bufs)) | |
732 (let ((master | 763 (let ((master |
733 (concat (file-name-as-directory | 764 (concat (file-name-as-directory |
734 (buffer-substring (point-min) | 765 (buffer-substring (point-min) |
735 (1- (point-max)))) | 766 (1- (point-max)))) |
736 basename | 767 basename |
737 ",v"))) | 768 ",v"))) |
738 (throw 'found (cons master 'CVS)))) | 769 (throw 'found (cons master 'CVS)))) |
739 (t (setq case-fold-search fold) ;; restore the old value | 770 (t (setq case-fold-search fold) ;; restore the old value |
740 nil))) | 771 nil))) |
741 (mapcar (function kill-buffer) bufs))))) | 772 (kill-buffer buffer))))) |
742 | 773 |
743 (defun vc-buffer-backend () | 774 (defun vc-buffer-backend () |
744 "Return the version-control type of the visited file, or nil if none." | 775 "Return the version-control type of the visited file, or nil if none." |
745 (if (eq vc-buffer-backend t) | 776 (if (eq vc-buffer-backend t) |
746 (setq vc-buffer-backend (vc-backend (buffer-file-name))) | 777 (setq vc-buffer-backend (vc-backend (buffer-file-name))) |