Improved extra-headers method for CVS.

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 151e3c2a532a070a53688122b04d274ae994bc57..36b146f59ba6aec4266c836de836709fc26ec022 100644 (file)
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -4,7 +4,7 @@
        the end of the file, it was good work at one time but has been
        stale since 1995 and may now be actively misleading.
        * vc-cvs.el (vc-cvs-status-extra-headers): Extract and display the
-       CVS repository.
+       CVS repository and module (assumptions for the latter a bit iffy).
        * vc-svn.el (vc-svn-status-extra-headers): Extract and display the
        SVN repository.
 

diff --git a/lisp/vc-cvs.el b/lisp/vc-cvs.el
index 40f601a77388fb7f759098438e4aac4c262c97c3..193fcfad5ea53f41abc953cb73e9dc7e59a4b51b 100644 (file)
--- a/lisp/vc-cvs.el
+++ b/lisp/vc-cvs.el
@@ -921,27 +921,50 @@ state."
   (vc-exec-after
    `(vc-cvs-after-dir-status (quote ,update-function))))
 
+(defun vc-cvs-file-to-string (file)
+  "Read the content of FILE and return it as a string."
+  (condition-case nil
+      (with-temp-buffer
+       (insert-file-contents file)
+       (goto-char (point-min))
+       (buffer-substring (point) (point-max)))
+    (file-error nil)))
+
 (defun vc-cvs-status-extra-headers (dir)
+  "Extract and represent per-directory properties of a CVS working copy."
   (let ((repo
-        (condition-case nil 
-            (save-excursion 
-              (set-buffer (find-file-noselect "CVS/Root" t))
+        (condition-case nil
+            (with-temp-buffer
+              (insert-file-contents "CVS/Root")
+              (goto-char (point-min))
               (and (looking-at ":ext:") (delete-char 5))
-              (prog1 (buffer-string) (not-modified) (kill-buffer nil)))
-          nil)))
+              (buffer-substring (point) (point-max)))
+          (file-error nil)))
+       (module
+        (condition-case nil
+            (with-temp-buffer
+              (insert-file-contents "CVS/Repository")
+              (goto-char (point-min))
+              (re-search-forward "[^/]*" nil t)
+              (concat (match-string 0) "\n"))
+          (file-error nil))))
     (concat
-     ;; FIXME: see how PCL-CVS gets the data to print all these
-     (propertize "Module     : " 'face 'font-lock-type-face)
-     (propertize "ADD CODE TO PRINT THE MODULE\n"
-                'face 'font-lock-warning-face)
+     (cond (module
+           (concat
+             (propertize "Module:      " 'face 'font-lock-type-face)
+             (propertize module 'face 'font-lock-variable-name-face)))
+          (t ""))
      (cond (repo
            (concat
-             (propertize "Repository : " 'face 'font-lock-type-face)
-             (propertize repo 'face 'font-lock-warning-face)))
+             (propertize "Repository:   " 'face 'font-lock-type-face)
+             (propertize repo 'face 'font-lock-variable-name-face)))
           (t ""))
-     (propertize "Branch     : " 'face 'font-lock-type-face)
-     (propertize "ADD CODE TO PRINT THE BRANCH NAME\n"
-                'face 'font-lock-warning-face))))
+     ;; In CVS, branch is a per-file property, not a per-directory property.  We 
+     ;; can't really do this here without making dangerous assumptions. 
+     ;;(propertize "Branch:     " 'face 'font-lock-type-face)
+     ;;(propertize "ADD CODE TO PRINT THE BRANCH NAME\n"
+     ;;         'face 'font-lock-warning-face)
+     )))
 
 (defun vc-cvs-get-entries (dir)
   "Insert the CVS/Entries file from below DIR into the current buffer.

diff --git a/lisp/vc.el b/lisp/vc.el
index 4ba89789b30bf827da95f1de6210ba58b7eff77d..bcb5fd18d8bf4fbffbcbcbbf7913234e27f65f0a 100644 (file)
--- a/lisp/vc.el
+++ b/lisp/vc.el
@@ -1798,9 +1798,9 @@ See Info node `Merging'."
 It calls the `status-extra-headers' backend method to display backend
 specific headers."
   (concat
-   (propertize "VC backend : " 'face 'font-lock-type-face)
+   (propertize "VC backend:  " 'face 'font-lock-type-face)
    (propertize (format "%s\n" backend) 'face 'font-lock-variable-name-face)
-   (propertize "Working dir: " 'face 'font-lock-type-face)
+   (propertize "Working dir:  " 'face 'font-lock-type-face)
    (propertize (format "%s\n" dir) 'face 'font-lock-variable-name-face)
    (vc-call-backend backend 'status-extra-headers dir)
    "\n"))