From 6d31a16652ec7e840df3e7f2f563518ee61802b6 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 9 Jan 2008 19:23:43 +0000
Subject: [PATCH] Fix bug: VC-CONTROL-DIRECTORIES must handle shadowing of
 inherited control directories.  In other words, if directory A has a .bzr
 subdirectory, and A/B has a .svn directory, then files in A/B/C should ignore
 the .bzr directory in A.

---
 v7/src/edwin/vc.scm | 71 ++++++++++++++++++++++++++-------------------
 1 file changed, 41 insertions(+), 30 deletions(-)

diff --git a/v7/src/edwin/vc.scm b/v7/src/edwin/vc.scm
index 6b8e0f281..731a5199d 100644
--- a/v7/src/edwin/vc.scm
+++ b/v7/src/edwin/vc.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: vc.scm,v 1.110 2007/12/20 02:49:18 cph Exp $
+$Id: vc.scm,v 1.111 2008/01/09 19:23:43 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -1177,33 +1177,6 @@ the value of vc-log-mode-hook."
 	 (or ((vc-type-operation (caar ps) 'FIND-MASTER) workfile (cdar ps))
 	     (loop (cdr ps))))))
 
-(define (vc-control-directories workfile)
-  (let ((start (merge-pathnames (directory-pathname workfile))))
-    (let loop ((path (pathname-directory start)) (types vc-types))
-      (let ((directory (pathname-new-directory start path)))
-	(let per-dir ((types types) (good '()) (maybe '()))
-	  (cond ((pair? types)
-		 (let ((control-dir
-			((vc-type-operation (car types) 'CONTROL-DIRECTORY)
-			 directory)))
-		   (cond ((not control-dir)
-			  (per-dir (cdr types)
-				   good
-				   maybe))
-			 ((eq? control-dir 'SEARCH-PARENT)
-			  (per-dir (cdr types)
-				   good
-				   (cons (car types) maybe)))
-			 (else
-			  (per-dir (cdr types)
-				   (cons (cons (car types) control-dir) good)
-				   maybe)))))
-		((pair? good) good)
-		((and (pair? (cdr path))
-		      (pair? maybe))
-		 (loop (except-last-pair path) maybe))
-		(else '())))))))
-
 (define (vc-backend-master-valid? master)
   ;; MASTER is a VC-MASTER object.
   ;; The return value is a boolean indicating that MASTER is valid.
@@ -1220,7 +1193,7 @@ the value of vc-log-mode-hook."
   ;; The last checked-in revision of the file is returned.
   ;; If this can't be determined, #F is returned.
   (vc-call 'WORKFILE-REVISION master))
-
+
 (define (vc-backend-locking-user master revision)
   ;; MASTER is a valid VC-MASTER object.
   ;; REVISION is a revision string or #F.
@@ -1363,13 +1336,51 @@ the value of vc-log-mode-hook."
   ;; appropriate revision-control header strings.  Returns #t iff the
   ;; header strings are present.
   (vc-call 'CHECK-HEADERS master buffer))
-
+
 (define (vc-backend-mode-line-status master buffer)
   (let ((operation
 	 (vc-type-operation (vc-master-type master) 'MODE-LINE-STATUS #f)))
     (if operation
 	(operation master buffer)
 	(%default-mode-line-status master buffer))))
+
+(define (vc-control-directories workfile)
+  (let ((start (merge-pathnames (directory-pathname workfile))))
+    (let loop ((path (pathname-directory start)) (possible vc-types))
+      (let ((directory (pathname-new-directory start path)))
+	(receive (good maybe) (local-control-directories directory)
+	  (or (let ((good*
+		     (filter (lambda (p) (memq (car p) possible))
+			     good)))
+		(and (pair? good*)
+		     good*))
+	      (if (and (null? good)
+		       (pair? (cdr path)))
+		  (let ((maybe (lset-intersection eqv? maybe possible)))
+		    (if (pair? maybe)
+			(loop (except-last-pair path) maybe)
+			'()))
+		  '())))))))
+
+(define (local-control-directories directory)
+  (let loop ((types vc-types) (good '()) (maybe '()))
+    (if (pair? types)
+	(let ((control-dir
+	       ((vc-type-operation (car types) 'CONTROL-DIRECTORY)
+		directory)))
+	  (cond ((not control-dir)
+		 (loop (cdr types)
+		       good
+		       maybe))
+		((eq? control-dir 'SEARCH-PARENT)
+		 (loop (cdr types)
+		       good
+		       (cons (car types) maybe)))
+		(else
+		 (loop (cdr types)
+		       (cons (cons (car types) control-dir) good)
+		       maybe))))
+	(values good maybe))))
 
 ;;;; RCS Commands
 
-- 
2.25.1