(vc-do-command): Arrange for the default-directory variable

in *vc* to be re-set each time this function uses it.
Discard current dir from front of FILE later on,
and only if last = `WORKFILE'.

Undo Dec 10 change:
(vc-directory, vc-dired-reformat-line): Changed back.
(vc-directory-18): Old function restored.
(vc-dir-all-files): Function deleted.

(vc-next-action-on-file): If file is not registered,
check file out after registering it.
(vc-next-action-dired): Restore the window configuration after
doing vc-next-action on each file in a VC-dired buffer.
(file-regular-p-18): New function.
(file-regular-p): Define, if not already defined.

1 files changed, 147 insertions, 90 deletions

diff --git a/lisp/vc.el b/lisp/vc.el
index bef1b7de505..8972849cb9a 100644
--- a/lisp/vc.el
+++ b/lisp/vc.el
@@ -1,10 +1,10 @@
 ;;; vc.el --- drive a version-control system from within Emacs
 
-;; Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc.
+;; Copyright (C) 1992, 1993, 1994, 1995 Free Software Foundation, Inc.
 
 ;; Author: Eric S. Raymond <esr@snark.thyrsus.com>
 ;; Maintainer: ttn@netcom.com
-;; Version: 5.5 + CVS hacks by ceder@lysator.liu.se made in Jan-Feb 1994.
+;; Version: 5.6
 
 ;; This file is part of GNU Emacs.
 
@@ -29,10 +29,15 @@
 ;; This was designed and implemented by Eric Raymond <esr@snark.thyrsus.com>.
 ;; Paul Eggert <eggert@twinsun.com>, Sebastian Kremer <sk@thp.uni-koeln.de>,
 ;; and Richard Stallman contributed valuable criticism, support, and testing.
+;; CVS support was added by Per Cederqvist <ceder@lysator.liu.se>
+;; in Jan-Feb 1994.
 ;;
-;; Supported version-control systems presently include SCCS and RCS;
-;; the RCS lock-stealing code doesn't work right unless you use RCS 5.6.2
+;; Supported version-control systems presently include SCCS, RCS, and CVS.
+;; The RCS lock-stealing code doesn't work right unless you use RCS 5.6.2
 ;; or newer.  Currently (January 1994) that is only a beta test release.
+;; Even initial checkins will fail if your RCS version is so old that ci
+;; doesn't understand -t-; this has been known to happen to people running
+;; NExTSTEP 3.0. 
 ;;
 ;; The RCS code assumes strict locking.  You can support the RCS -x option
 ;; by adding pairs to the vc-master-templates list.
@@ -93,6 +98,8 @@ value of this flag.")
   (if (file-exists-p "/usr/sccs")
       '("/usr/sccs") nil)
   "*List of extra directories to search for version control commands.")
+(defvar vc-directory-exclusion-list '("SCCS" "RCS")
+  "*Directory names ignored by functions that recursively walk file trees.")
 
 (defconst vc-maximum-comment-ring-size 32
   "Maximum number of saved comments in the comment ring.")
@@ -159,6 +166,27 @@ and that its contents match what the master file says.")
 (defvar vc-comment-ring-index nil)
 (defvar vc-last-comment-match nil)
 
+;; Back-portability to Emacs 18
+
+(defun file-executable-p-18 (f)
+  (let ((modes (file-modes f)))
+    (and modes (not (zerop (logand 292))))))
+
+(defun file-regular-p-18 (f)
+  (let ((attributes (file-attributes f)))
+    (and attributes (not (car attributes)))))
+
+; Conditionally rebind some things for Emacs 18 compatibility
+(if (not (boundp 'minor-mode-map-alist))
+    (progn
+      (setq compilation-old-error-list nil)
+      (fset 'file-executable-p 'file-executable-p-18)
+      (fset 'shrink-window-if-larger-than-buffer 'beginning-of-buffer)
+      ))
+
+(if (not (boundp 'file-regular-p))
+    (fset 'file-regular-p 'file-regular-p-18))
+
 ;; File property caching
 
 (defun vc-file-clearprops (file)
@@ -203,35 +231,37 @@ and that its contents match what the master file says.")
   "Execute a version-control command, notifying user and checking for errors.
 The command is successful if its exit status does not exceed OKSTATUS.
 Output from COMMAND goes to buffer *vc*.  The last argument of the command is
-the master name of FILE if LAST is 'MASTER, or the basename of FILE if LAST is
-'BASE; this is appended to an optional list of FLAGS."
+the master name of FILE if LAST is 'MASTER, or the workfile of FILE if LAST is
+'WORKFILE; this is appended to an optional list of FLAGS."
   (setq file (expand-file-name file))
   (if vc-command-messages
       (message "Running %s on %s..." command file))
   (let ((obuf (current-buffer)) (camefrom (current-buffer))
         (squeezed nil)
         (vc-file (and file (vc-name file)))
+        (olddir default-directory)
         status)
     (set-buffer (get-buffer-create "*vc*"))
     (set (make-local-variable 'vc-parent-buffer) camefrom)
     (set (make-local-variable 'vc-parent-buffer-name)
          (concat " from " (buffer-name camefrom)))
+    (setq default-directory olddir)
     
     (erase-buffer)
 
-    ;; This is so that command arguments typed in the *vc* buffer will
-    ;; have reasonable defaults.
-    (setq default-directory (file-name-directory file))
-
     (mapcar
      (function (lambda (s) (and s (setq squeezed (append squeezed (list s))))))
      flags)
     (if (and vc-file (eq last 'MASTER))
         (setq squeezed (append squeezed (list vc-file))))
-    (if (eq last 'BASE)
-        (setq squeezed (append squeezed (list (file-name-nondirectory file)))))
-    (let ((default-directory (file-name-directory (or file "./")))
-          (exec-path (if vc-path (append exec-path vc-path) exec-path))
+    (if (eq last 'WORKFILE)
+        (progn
+          (let* ((pwd (expand-file-name default-directory))
+                 (preflen (length pwd)))
+            (if (string= (substring file 0 preflen) pwd)
+                (setq file (substring file preflen))))
+          (setq squeezed (append squeezed (list file)))))
+    (let ((exec-path (if vc-path (append exec-path vc-path) exec-path))
           ;; Add vc-path to PATH for the execution of this command.
           (process-environment
            (cons (concat "PATH=" (getenv "PATH")
@@ -239,6 +269,7 @@ the master name of FILE if LAST is 'MASTER, or the basename of FILE if LAST is
                  process-environment)))
       (setq status (apply 'call-process command nil t nil squeezed)))
     (goto-char (point-max))
+    (set-buffer-modified-p nil)
     (forward-line -1)
     (if (or (not (integerp status)) (< okstatus status))
         (progn
@@ -324,8 +355,16 @@ the master name of FILE if LAST is 'MASTER, or the basename of FILE if LAST is
                                       (if buffer-error-marked-p buffer))))
                                   (buffer-list)))))))
 
-    ;; the actual revisit
-    (revert-buffer arg no-confirm)
+    (let ((in-font-lock-mode (and (boundp 'font-lock-fontified)
+                                font-lock-fontified)))
+      (if in-font-lock-mode
+          (font-lock-mode 0))
+
+      ;; the actual revisit
+      (revert-buffer arg no-confirm)
+
+      (if in-font-lock-mode
+          (font-lock-mode 1)))
 
     ;; Reparse affected compilation buffers.
     (while reparse
@@ -387,7 +426,11 @@ the master name of FILE if LAST is 'MASTER, or the basename of FILE if LAST is
 
      ;; if there is no master file corresponding, create one
      ((not vc-file)
-      (vc-register verbose comment))
+      (vc-register verbose comment)
+      (if vc-initial-comment
+          (setq vc-log-after-operation-hook
+                'vc-checkout-writable-buffer-hook)
+        (vc-checkout-writable-buffer file)))
 
      ;; if there is no lock on the file, assert one and get it
      ((and (not (eq vc-type 'CVS))      ;There are no locks in CVS.
@@ -491,13 +534,15 @@ the master name of FILE if LAST is 'MASTER, or the basename of FILE if LAST is
   ;; We've accepted a log comment, now do a vc-next-action using it on all
   ;; marked files.
   (set-buffer vc-parent-buffer)
-  (dired-map-over-marks
-   (save-window-excursion
-     (let ((file (dired-get-filename)))
-       (message "Processing %s..." file)
-       (vc-next-action-on-file file nil comment)
-       (message "Processing %s...done" file)))
-   nil t)
+  (let ((configuration (current-window-configuration)))
+    (dired-map-over-marks
+     (save-window-excursion
+       (let ((file (dired-get-filename)))
+         (message "Processing %s..." file)
+         (vc-next-action-on-file file nil comment)
+         (message "Processing %s...done" file)))
+     nil t)
+    (set-window-configuration configuration))
   )
 
 ;; Here's the major entry point.
@@ -893,7 +938,7 @@ and two version designators specifying which versions to compare."
         ;; visited.  This plays hell with numerous assumptions in
         ;; the diff.el and compile.el machinery.
         (pop-to-buffer "*vc*")
-        (pop-to-buffer "*vc*")
+        (setq default-directory (file-name-directory file))
         (if (= 0 (buffer-size))
             (progn
               (setq unchanged t)
@@ -1034,51 +1079,45 @@ on a buffer attached to the file named in the current Dired buffer line."
     (cond
      ((re-search-forward "\\([0-9]+ \\)\\([^ ]+\\)\\( .*\\)" nil 0)
       (save-excursion
-        (goto-char (match-beginning 2))
-        (insert "(")
-        (goto-char (1+ (match-end 2)))
-        (insert ")")
-        (delete-char (- 17 (- (match-end 2) (match-beginning 2))))
-        (insert (substring "      " 0
-                           (- 7 (- (match-end 2) (match-beginning 2)))))))))
+       (goto-char (match-beginning 2))
+       (insert "(")
+       (goto-char (1+ (match-end 2)))
+       (insert ")")
+       (delete-char (- 17 (- (match-end 2) (match-beginning 2))))
+       (insert (substring "      " 0
+                          (- 7 (- (match-end 2) (match-beginning 2)))))))))
    (t
     (if x (setq x (concat "(" x ")")))
     (if (re-search-forward "\\([0-9]+ \\).................\\( .*\\)" nil 0)
-        (let ((rep (substring (concat x "                 ") 0 9)))
-          (replace-match (concat "\\1" rep "\\2") t)))
+       (let ((rep (substring (concat x "                 ") 0 9)))
+         (replace-match (concat "\\1" rep "\\2") t)))
     )))
 
+;;; Note in Emacs 18 the following defun gets overridden
+;;; with the symbol 'vc-directory-18.  See below.
 ;;;###autoload
-(defun vc-directory (dir verbose &optional nested)
-  "Show version-control status of all files in the directory DIR.
-If the second argument VERBOSE is non-nil, show all files;
-otherwise show only files that current locked in the version control system.
-Interactively, supply a prefix arg to make VERBOSE non-nil.
-
-If the optional third argument NESTED is non-nil,
-scan the entire tree of subdirectories of the current directory."
-  (interactive "DVC status of directory: \nP")
-  (let* (nonempty
-         (dl (length dir))
-         (filelist nil) (userlist nil)
-         dired-buf
-         dired-buf-mod-count
-         (subfunction
-          (function (lambda (f)
-                      (if (vc-registered f)
-                          (let ((user (vc-locking-user f)))
-                            (and (or verbose user)
-                                 (setq filelist (cons (substring f dl) filelist))
-                                 (setq userlist (cons user userlist)))))))))
-    (let ((default-directory dir))
-      (if nested
-          (vc-file-tree-walk subfunction)
-        (vc-dir-all-files subfunction)))
+(defun vc-directory (verbose)
+  "Show version-control status of the current directory and subdirectories.
+Normally it creates a Dired buffer that lists only the locked files
+in all these directories.  With a prefix argument, it lists all files."
+  (interactive "P")
+  (let (nonempty
+        (dl (length default-directory))
+        (filelist nil) (userlist nil)
+        dired-buf
+        dired-buf-mod-count)
+    (vc-file-tree-walk
+     (function (lambda (f)
+                 (if (vc-registered f)
+                     (let ((user (vc-locking-user f)))
+                       (and (or verbose user)
+                            (setq filelist (cons (substring f dl) filelist))
+                            (setq userlist (cons user userlist))))))))
     (save-excursion
       ;; This uses a semi-documented feature of dired; giving a switch
       ;; argument forces the buffer to refresh each time.
       (dired
-       (cons dir (nreverse filelist))
+       (cons default-directory (nreverse filelist))
        dired-listing-switches)
       (setq dired-buf (current-buffer))
       (setq nonempty (not (zerop (buffer-size)))))
@@ -1103,9 +1142,35 @@ scan the entire tree of subdirectories of the current directory."
                (if verbose "registered" "locked") default-directory))
     ))
 
-; Emacs 18 also lacks these.
-(or (boundp 'compilation-old-error-list)
-    (setq compilation-old-error-list nil))
+;; Emacs 18 version
+(defun vc-directory-18 (verbose)
+  "Show version-control status of all files under the current directory."
+  (interactive "P")
+  (let (nonempty (dir default-directory))
+    (save-excursion
+      (set-buffer (get-buffer-create "*vc-status*"))
+      (erase-buffer)
+      (cd dir)
+      (vc-file-tree-walk
+       (function (lambda (f)
+                   (if (vc-registered f)
+                       (let ((user (vc-locking-user f)))
+                         (if (or user verbose)
+                             (insert (format
+                                      "%s       %s\n"
+                                      (concat user) f))))))))
+      (setq nonempty (not (zerop (buffer-size)))))
+    (if nonempty
+        (progn
+          (pop-to-buffer "*vc-status*" t)
+          (goto-char (point-min))
+          (shrink-window-if-larger-than-buffer)))
+      (message "No files are currently %s under %s"
+               (if verbose "registered" "locked") default-directory))
+    )
+
+(or (boundp 'minor-mode-map-alist)
+    (fset 'vc-directory 'vc-directory-18))
 
 ;; Named-configuration support for SCCS
 
@@ -1198,9 +1263,10 @@ levels in the snapshot."
   (while vc-parent-buffer
       (pop-to-buffer vc-parent-buffer))
   (if (and buffer-file-name (vc-name buffer-file-name))
-      (progn
-        (vc-backend-print-log buffer-file-name)
+      (let ((file buffer-file-name))
+        (vc-backend-print-log file)
         (pop-to-buffer (get-buffer-create "*vc*"))
+        (setq default-directory (file-name-directory file))
         (while (looking-at "=*\n")
           (delete-char (- (match-end 0) (match-beginning 0)))
           (forward-line -1))
@@ -1424,7 +1490,7 @@ From a program, any arguments are passed to the `rcs2log' script."
           (setq buf (create-file-buffer file))
           (set-buffer buf))
         (erase-buffer)
-        (insert-file-contents file nil)
+        (insert-file-contents file)
         (set-buffer-modified-p nil)
         (auto-save-mode nil)
         (prog1
@@ -1602,7 +1668,7 @@ with RCS)."
    ;; should always be nil anyhow.  Don't fetch vc-your-latest-version, since
    ;; that is done in vc-find-cvs-master.
    (vc-log-info
-    "cvs" file 'BASE '("status")
+    "cvs" file 'WORKFILE '("status")
     ;; CVS 1.3 says "RCS Version:", other releases "RCS Revision:",
     ;; and CVS 1.4a1 says "Repository revision:".  The regexp below
     ;; matches much more, but because of the way vc-log-info is
@@ -1654,7 +1720,7 @@ with RCS)."
                           (and comment (concat "-t-" comment))
                           file))
           ((eq backend 'CVS)
-           (vc-do-command 0 "cvs" file 'BASE ;; CVS
+           (vc-do-command 0 "cvs" file 'WORKFILE ;; CVS
                           "add"
                           (and comment (not (string= comment ""))
                                (concat "-m" comment)))
@@ -1737,7 +1803,7 @@ with RCS)."
               (unwind-protect
                   (progn
                     (apply 'vc-do-command
-                           0 "/bin/sh" file 'BASE "-c"
+                           0 "/bin/sh" file 'WORKFILE "-c"
                            "exec >\"$1\" || exit; shift; exec cvs update \"$@\""
                            ""           ; dummy argument for shell's $0
                            workfile
@@ -1746,7 +1812,7 @@ with RCS)."
                            vc-checkout-switches)
                     (setq failed nil))
                 (and failed (file-exists-p filename) (delete-file filename))))
-          (apply 'vc-do-command 0 "cvs" file 'BASE
+          (apply 'vc-do-command 0 "cvs" file 'WORKFILE
                  (and rev (concat "-r" rev))
                  file
                  vc-checkout-switches))
@@ -1791,7 +1857,7 @@ with RCS)."
              (concat "-m" comment)
              vc-checkin-switches)
       (progn
-        (apply 'vc-do-command 0 "cvs" file 'BASE 
+        (apply 'vc-do-command 0 "cvs" file 'WORKFILE 
                "ci" "-m" comment
                vc-checkin-switches)
         (vc-file-setprop file 'vc-checkout-time 
@@ -1813,7 +1879,7 @@ with RCS)."
                   "-f" "-u")
    (progn                                 ;; CVS
      (delete-file file)
-     (vc-do-command 0 "cvs" file 'BASE "update"))
+     (vc-do-command 0 "cvs" file 'WORKFILE "update"))
    )
   (vc-file-setprop file 'vc-locking-user nil)
   (message "Reverting %s...done" file)
@@ -1853,14 +1919,14 @@ with RCS)."
    file
    (vc-do-command 0 "prs" file 'MASTER)
    (vc-do-command 0 "rlog" file 'MASTER)
-   (vc-do-command 0 "cvs" file 'BASE "rlog")))
+   (vc-do-command 0 "cvs" file 'WORKFILE "rlog")))
 
 (defun vc-backend-assign-name (file name)
   ;; Assign to a FILE's latest version a given NAME.
   (vc-backend-dispatch file
    (vc-add-triple name file (vc-latest-version file))           ;; SCCS
    (vc-do-command 0 "rcs" file 'MASTER (concat "-n" name ":"))  ;; RCS
-   (vc-do-command 0 "cvs" file 'BASE "tag" name)                ;; CVS
+   (vc-do-command 0 "cvs" file 'WORKFILE "tag" name)            ;; CVS
    )
   )
 
@@ -1878,6 +1944,7 @@ with RCS)."
       (let* ((command (if (eq backend 'SCCS)
                           "vcdiff"
                         "rcsdiff"))
+             (mode (if (eq backend 'RCS) 'WORKFILE 'MASTER))
              (options (append (list (and cmp "--brief")
                                     "-q"
                                     (and oldvers (concat "-r" oldvers))
@@ -1886,10 +1953,10 @@ with RCS)."
                                    (if (listp diff-switches)
                                        diff-switches
                                      (list diff-switches)))))
-             (status (apply 'vc-do-command 2 command file options)))
+             (status (apply 'vc-do-command 2 command file mode options)))
         ;; Some RCS versions don't understand "--brief"; work around this.
         (if (eq status 2)
-            (apply 'vc-do-command 1 command file 'MASTER
+            (apply 'vc-do-command 1 command file 'WORKFILE
                    (if cmp (cdr options) options))
           status)))
      ;; CVS is different.  
@@ -1901,12 +1968,12 @@ with RCS)."
           (if (or oldvers newvers)
               (error "No revisions of %s exists" file)
             (apply 'vc-do-command
-                   1 "diff" file 'BASE "/dev/null"
+                   1 "diff" file 'WORKFILE "/dev/null"
                    (if (listp diff-switches)
                        diff-switches
                      (list diff-switches))))
         (apply 'vc-do-command
-               1 "cvs" file 'BASE "diff"
+               1 "cvs" file 'WORKFILE "diff"
                (and oldvers (concat "-r" oldvers))
                (and newvers (concat "-r" newvers))
                (if (listp diff-switches)
@@ -1921,7 +1988,7 @@ with RCS)."
    file
    (error "vc-backend-merge-news not meaningful for SCCS files") ;SCCS
    (error "vc-backend-merge-news not meaningful for RCS files") ;RCS
-   (vc-do-command 1 "cvs" file 'BASE "update") ;CVS
+   (vc-do-command 1 "cvs" file 'WORKFILE "update") ;CVS
    ))
 
 (defun vc-check-headers ()
@@ -2041,23 +2108,13 @@ Invoke FUNC f ARGS on each non-directory file f underneath it."
         (lambda (f) (or
                      (string-equal f ".")
                      (string-equal f "..")
+                     (member f vc-directory-exclusion-list)
                      (let ((dirf (concat dir f)))
                         (or
                          (file-symlink-p dirf) ;; Avoid possible loops
                          (vc-file-tree-walk-internal dirf func args))))))
        (directory-files dir)))))
 
-(defun vc-dir-all-files (func &rest args)
-  "Invoke FUNC f ARGS on each regular file f in default directory."
-  (let ((dir default-directory))
-    (message "Scanning directory %s..." dir)
-    (mapcar (function (lambda (f)
-                        (let ((dirf (expand-file-name f dir)))
-                          (if (file-regular-p dirf)
-                              (apply func dirf args)))))
-            (directory-files dir))
-    (message "Scanning directory %s...done" dir)))
-
 (provide 'vc)
 
 ;;; DEVELOPER'S NOTES ON CONCURRENCY PROBLEMS IN THIS CODE