Mercurial > emacs

comparison lisp/vc.el @ 21233:8972762c8ca6

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
(vc-next-action-on-file): Properly handle the case when user tries to check-in, but file on disk has changed. (vc-do-command): Consider LAST argument only if FILE is non-nil. (vc-add-triple, vc-record-rename, vc-lookup-file): Find vc-name-assoc-file based on vc-name of FILE. (vc-backend-admin, vc-rename-file): Handle the SCCS PROJECTDIR feature. (vc-do-command): Rewrote doc string.
author André Spiegel <spiegel@gnu.org>
date Fri, 20 Mar 1998 15:40:24 +0000
parents 73a8874d25ce
children b0abfde79536
comparison
equal deleted inserted replaced
21232:b682a769996d 21233:8972762c8ca6
3 ;; Copyright (C) 1992, 93, 94, 95, 96, 97 Free Software Foundation, Inc. 3 ;; Copyright (C) 1992, 93, 94, 95, 96, 97 Free Software Foundation, Inc.
4 4
5 ;; Author: Eric S. Raymond <esr@snark.thyrsus.com> 5 ;; Author: Eric S. Raymond <esr@snark.thyrsus.com>
6 ;; Maintainer: Andre Spiegel <spiegel@inf.fu-berlin.de> 6 ;; Maintainer: Andre Spiegel <spiegel@inf.fu-berlin.de>
7 7
8 ;; $Id: vc.el,v 1.210 1998/03/08 10:03:50 spiegel Exp spiegel $ 8 ;; $Id: vc.el,v 1.211 1998/03/18 13:25:00 spiegel Exp spiegel $
9 9
10 ;; This file is part of GNU Emacs. 10 ;; This file is part of GNU Emacs.
11 11
12 ;; GNU Emacs is free software; you can redistribute it and/or modify 12 ;; GNU Emacs is free software; you can redistribute it and/or modify
13 ;; it under the terms of the GNU General Public License as published by 13 ;; it under the terms of the GNU General Public License as published by
522 exec-path) 522 exec-path)
523 nil))) 523 nil)))
524 524
525 (defun vc-do-command (buffer okstatus command file last &rest flags) 525 (defun vc-do-command (buffer okstatus command file last &rest flags)
526 "Execute a version-control command, notifying user and checking for errors. 526 "Execute a version-control command, notifying user and checking for errors.
527 Output from COMMAND goes to BUFFER, or *vc* if BUFFER is nil. 527 Output from COMMAND goes to BUFFER, or *vc* if BUFFER is nil. The
528 The command is successful if its exit status does not exceed OKSTATUS. 528 command is considered successful if its exit status does not exceed
529 (If OKSTATUS is nil, that means to ignore errors.) 529 OKSTATUS (if OKSTATUS is nil, that means to ignore errors). FILE is
530 The last argument of the command is the master name of FILE if LAST is 530 the name of the working file (may also be nil, to execute commands
531 `MASTER', or the workfile of FILE if LAST is `WORKFILE'; this is appended 531 that don't expect a file name). If FILE is non-nil, the argument LAST
532 to an optional list of FLAGS." 532 indicates what filename should actually be passed to the command: if
533 it is `MASTER', the name of FILE's master file is used, if it is
534 `WORKFILE', then FILE is passed through unchanged. If an optional
535 list of FLAGS is present, that is inserted into the command line
536 before the filename."
533 (and file (setq file (expand-file-name file))) 537 (and file (setq file (expand-file-name file)))
534 (if (not buffer) (setq buffer "*vc*")) 538 (if (not buffer) (setq buffer "*vc*"))
535 (if vc-command-messages 539 (if vc-command-messages
536 (message "Running %s on %s..." command file)) 540 (message "Running %s on %s..." command file))
537 (let ((obuf (current-buffer)) (camefrom (current-buffer)) 541 (let ((obuf (current-buffer)) (camefrom (current-buffer))
550 (mapcar 554 (mapcar
551 (function (lambda (s) (and s (setq squeezed (append squeezed (list s)))))) 555 (function (lambda (s) (and s (setq squeezed (append squeezed (list s))))))
552 flags) 556 flags)
553 (if (and vc-file (eq last 'MASTER)) 557 (if (and vc-file (eq last 'MASTER))
554 (setq squeezed (append squeezed (list vc-file)))) 558 (setq squeezed (append squeezed (list vc-file))))
555 (if (eq last 'WORKFILE) 559 (if (and file (eq last 'WORKFILE))
556 (progn 560 (progn
557 (let* ((pwd (expand-file-name default-directory)) 561 (let* ((pwd (expand-file-name default-directory))
558 (preflen (length pwd))) 562 (preflen (length pwd)))
559 (if (string= (substring file 0 preflen) pwd) 563 (if (string= (substring file 0 preflen) pwd)
560 (setq file (substring file preflen)))) 564 (setq file (substring file preflen))))
853 (t 857 (t
854 (if vc-dired-mode 858 (if vc-dired-mode
855 (find-file-other-window file) 859 (find-file-other-window file)
856 (find-file file)) 860 (find-file file))
857 861
858 ;; give luser a chance to save before checking in. 862 ;; If the file on disk is newer, then the user just
859 (vc-buffer-sync) 863 ;; said no to rereading it. So the user probably wishes to
864 ;; overwrite the file with the buffer's contents, and check
865 ;; that in.
866 (if (not (verify-visited-file-modtime (current-buffer)))
867 (if (yes-or-no-p "Replace file on disk with buffer contents? ")
868 (write-file (buffer-file-name))
869 (error "Aborted"))
870 ;; give luser a chance to save before checking in.
871 (vc-buffer-sync))
860 872
861 ;; Revert if file is unchanged and buffer is too. 873 ;; Revert if file is unchanged and buffer is too.
862 ;; If buffer is modified, that means the user just said no 874 ;; If buffer is modified, that means the user just said no
863 ;; to saving it; in that case, don't revert, 875 ;; to saving it; in that case, don't revert,
864 ;; because the user might intend to save 876 ;; because the user might intend to save
1666 1678
1667 (defun vc-add-triple (name file rev) 1679 (defun vc-add-triple (name file rev)
1668 (save-excursion 1680 (save-excursion
1669 (find-file (expand-file-name 1681 (find-file (expand-file-name
1670 vc-name-assoc-file 1682 vc-name-assoc-file
1671 (file-name-as-directory 1683 (file-name-directory (vc-name file))))
1672 (expand-file-name (vc-backend-subdirectory-name file)
1673 (file-name-directory file)))))
1674 (goto-char (point-max)) 1684 (goto-char (point-max))
1675 (insert name "\t:\t" file "\t" rev "\n") 1685 (insert name "\t:\t" file "\t" rev "\n")
1676 (basic-save-buffer) 1686 (basic-save-buffer)
1677 (kill-buffer (current-buffer)) 1687 (kill-buffer (current-buffer))
1678 )) 1688 ))
1680 (defun vc-record-rename (file newname) 1690 (defun vc-record-rename (file newname)
1681 (save-excursion 1691 (save-excursion
1682 (find-file 1692 (find-file
1683 (expand-file-name 1693 (expand-file-name
1684 vc-name-assoc-file 1694 vc-name-assoc-file
1685 (file-name-as-directory 1695 (file-name-directory (vc-name file))))
1686 (expand-file-name (vc-backend-subdirectory-name file)
1687 (file-name-directory file)))))
1688 (goto-char (point-min)) 1696 (goto-char (point-min))
1689 ;; (replace-regexp (concat ":" (regexp-quote file) "$") (concat ":" newname)) 1697 ;; (replace-regexp (concat ":" (regexp-quote file) "$") (concat ":" newname))
1690 (while (re-search-forward (concat ":" (regexp-quote file) "$") nil t) 1698 (while (re-search-forward (concat ":" (regexp-quote file) "$") nil t)
1691 (replace-match (concat ":" newname) nil nil)) 1699 (replace-match (concat ":" newname) nil nil))
1692 (basic-save-buffer) 1700 (basic-save-buffer)
1704 (save-excursion 1712 (save-excursion
1705 (set-buffer (get-buffer-create "*vc-info*")) 1713 (set-buffer (get-buffer-create "*vc-info*"))
1706 (vc-insert-file 1714 (vc-insert-file
1707 (expand-file-name 1715 (expand-file-name
1708 vc-name-assoc-file 1716 vc-name-assoc-file
1709 (file-name-as-directory 1717 (file-name-directory (vc-name file))))
1710 (expand-file-name (vc-backend-subdirectory-name file)
1711 (file-name-directory file)))))
1712 (prog1 1718 (prog1
1713 (car (vc-parse-buffer 1719 (car (vc-parse-buffer
1714 (list (list (concat name "\t:\t" file "\t\\(.+\\)") 1)))) 1720 (list (list (concat name "\t:\t" file "\t\\(.+\\)") 1))))
1715 (kill-buffer "*vc-info*")))) 1721 (kill-buffer "*vc-info*"))))
1716 )) 1722 ))
1960 (error "Please save files before moving them")) 1966 (error "Please save files before moving them"))
1961 (if (get-file-buffer new) 1967 (if (get-file-buffer new)
1962 (error "Already editing new file name")) 1968 (error "Already editing new file name"))
1963 (if (file-exists-p new) 1969 (if (file-exists-p new)
1964 (error "New file already exists")) 1970 (error "New file already exists"))
1965 (let ((oldmaster (vc-name old))) 1971 (let ((oldmaster (vc-name old)) newmaster)
1966 (if oldmaster 1972 (if oldmaster
1967 (progn 1973 (progn
1968 (if (vc-locking-user old) 1974 (if (vc-locking-user old)
1969 (error "Please check in files before moving them")) 1975 (error "Please check in files before moving them"))
1970 (if (or (file-symlink-p oldmaster) 1976 (if (or (file-symlink-p oldmaster)
1971 ;; This had FILE, I changed it to OLD. -- rms. 1977 ;; This had FILE, I changed it to OLD. -- rms.
1972 (file-symlink-p (vc-backend-subdirectory-name old))) 1978 (file-symlink-p (vc-backend-subdirectory-name old)))
1973 (error "This is not a safe thing to do in the presence of symbolic links")) 1979 (error "This is not a safe thing to do in the presence of symbolic links"))
1974 (rename-file 1980 (setq newmaster
1975 oldmaster 1981 (let ((backend (vc-backend old))
1976 (let ((backend (vc-backend old)) 1982 (newdir (or (file-name-directory new) ""))
1977 (newdir (or (file-name-directory new) "")) 1983 (newbase (file-name-nondirectory new)))
1978 (newbase (file-name-nondirectory new))) 1984 (catch 'found
1979 (catch 'found 1985 (mapcar
1980 (mapcar 1986 (function
1981 (function 1987 (lambda (s)
1982 (lambda (s) 1988 (if (eq backend (cdr s))
1983 (if (eq backend (cdr s)) 1989 (let* ((newmaster (format (car s) newdir newbase))
1984 (let* ((newmaster (format (car s) newdir newbase)) 1990 (newmasterdir (file-name-directory newmaster)))
1985 (newmasterdir (file-name-directory newmaster))) 1991 (if (or (not newmasterdir)
1986 (if (or (not newmasterdir) 1992 (file-directory-p newmasterdir))
1987 (file-directory-p newmasterdir)) 1993 (throw 'found newmaster))))))
1988 (throw 'found newmaster)))))) 1994 vc-master-templates)
1989 vc-master-templates) 1995 (error "New file lacks a version control directory"))))
1990 (error "New file lacks a version control directory")))))) 1996 ;; Handle the SCCS PROJECTDIR feature. It is odd that this
1997 ;; is a special case, but a more elegant solution would require
1998 ;; significant changes in other parts of VC.
1999 (if (eq (vc-backend old) 'SCCS)
2000 (let ((project-dir (vc-sccs-project-dir)))
2001 (if project-dir
2002 (setq newmaster
2003 (concat project-dir
2004 (file-name-nondirectory newmaster))))))
2005 (rename-file oldmaster newmaster)))
1991 (if (or (not oldmaster) (file-exists-p old)) 2006 (if (or (not oldmaster) (file-exists-p old))
1992 (rename-file old new))) 2007 (rename-file old new)))
1993 ; ?? Renaming a file might change its contents due to keyword expansion. 2008 ; ?? Renaming a file might change its contents due to keyword expansion.
1994 ; We should really check out a new copy if the old copy was precisely equal 2009 ; We should really check out a new copy if the old copy was precisely equal
1995 ; to some checked in version. However, testing for this is tricky.... 2010 ; to some checked in version. However, testing for this is tricky....
2287 ;; it deletes the workfile. 2302 ;; it deletes the workfile.
2288 (vc-file-clearprops file) 2303 (vc-file-clearprops file)
2289 (or vc-default-back-end 2304 (or vc-default-back-end
2290 (setq vc-default-back-end (if (vc-find-binary "rcs") 'RCS 'SCCS))) 2305 (setq vc-default-back-end (if (vc-find-binary "rcs") 'RCS 'SCCS)))
2291 (message "Registering %s..." file) 2306 (message "Registering %s..." file)
2292 (let ((switches 2307 (let* ((switches
2293 (if (stringp vc-register-switches) 2308 (if (stringp vc-register-switches)
2294 (list vc-register-switches) 2309 (list vc-register-switches)
2295 vc-register-switches)) 2310 vc-register-switches))
2296 (backend 2311 (project-dir)
2297 (cond 2312 (backend
2298 ((file-exists-p (vc-backend-subdirectory-name)) vc-default-back-end) 2313 (cond
2299 ((file-exists-p "RCS") 'RCS) 2314 ((file-exists-p (vc-backend-subdirectory-name)) vc-default-back-end)
2300 ((file-exists-p "SCCS") 'SCCS) 2315 ((file-exists-p "RCS") 'RCS)
2301 ((file-exists-p "CVS") 'CVS) 2316 ((file-exists-p "CVS") 'CVS)
2302 (t vc-default-back-end)))) 2317 ((file-exists-p "SCCS") 'SCCS)
2318 ((setq project-dir (vc-sccs-project-dir)) 'SCCS)
2319 (t vc-default-back-end))))
2303 (cond ((eq backend 'SCCS) 2320 (cond ((eq backend 'SCCS)
2304 ;; If there is no SCCS subdirectory yet, create it. 2321 (let ((vc-name
2305 ;; (SCCS could do without it, but VC requires it to be there.) 2322 (if project-dir (concat project-dir
2306 (if (not (file-exists-p "SCCS")) (make-directory "SCCS")) 2323 "s." (file-name-nondirectory file))
2307 (apply 'vc-do-command nil 0 "admin" file 'MASTER ;; SCCS 2324 (format
2308 (and rev (concat "-r" rev)) 2325 (car (rassq 'SCCS vc-master-templates))
2309 "-fb" 2326 (or (file-name-directory file) "")
2310 (concat "-i" file) 2327 (file-name-nondirectory file)))))
2311 (and comment (concat "-y" comment)) 2328 (apply 'vc-do-command nil 0 "admin" nil nil ;; SCCS
2312 (format 2329 (and rev (concat "-r" rev))
2313 (car (rassq 'SCCS vc-master-templates)) 2330 "-fb"
2314 (or (file-name-directory file) "") 2331 (concat "-i" file)
2315 (file-name-nondirectory file)) 2332 (and comment (concat "-y" comment))
2316 switches) 2333 vc-name
2334 switches))
2317 (delete-file file) 2335 (delete-file file)
2318 (if vc-keep-workfiles 2336 (if vc-keep-workfiles
2319 (vc-do-command nil 0 "get" file 'MASTER))) 2337 (vc-do-command nil 0 "get" file 'MASTER)))
2320 ((eq backend 'RCS) 2338 ((eq backend 'RCS)
2321 (apply 'vc-do-command nil 0 "ci" file 'WORKFILE ;; RCS 2339 (apply 'vc-do-command nil 0 "ci" file 'WORKFILE ;; RCS