changeset 95049:438808a998aa

Improved extra-headers method for CVS.

--- a/lisp/ChangeLog	Fri May 16 18:15:26 2008 +0000
+++ b/lisp/ChangeLog	Fri May 16 19:15:26 2008 +0000
@@ -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.
 

--- a/lisp/vc-cvs.el	Fri May 16 18:15:26 2008 +0000
+++ b/lisp/vc-cvs.el	Fri May 16 19:15:26 2008 +0000
@@ -921,27 +921,50 @@
   (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.

--- a/lisp/vc.el	Fri May 16 18:15:26 2008 +0000
+++ b/lisp/vc.el	Fri May 16 19:15:26 2008 +0000
@@ -1798,9 +1798,9 @@
 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"))