Add support for access to more than one database. There is no longer

a default database name, so the database to use must always be
specified by a URL binding.

diff --git a/v7/src/xdoc/db.scm b/v7/src/xdoc/db.scm
index 392876a4253622f0d3cd4b4ceea451d0448a71aa..924e734e6ab90b657cf32fc839076f0c0810038f 100644 (file)
--- a/v7/src/xdoc/db.scm
+++ b/v7/src/xdoc/db.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: db.scm,v 1.4 2004/11/22 20:08:42 cph Exp $
+$Id: db.scm,v 1.5 2004/11/26 15:17:18 cph Exp $
 
 Copyright 2003,2004 Massachusetts Institute of Technology
 
@@ -27,73 +27,51 @@ USA.
 
 (declare (usual-integrations))
 \f
-(define default-db-name "six002x_spring04")
-(define pgsql-conn #f)
+(define database-connections '())
 (define *database-connection* #f)
 (define *user-name*)
 (define *ps-number*)
-(define *page-pathname*)
 (define *page-key*)
 
-(define (with-database-connection ps-number pathname thunk)
-  (if (not (and pgsql-conn (pgsql-conn-open? pgsql-conn)))
-      (set! pgsql-conn (open-pgsql-conn (get-db-open-args pathname))))
-  (let ((page-key (enough-namestring pathname (server-root-dir))))
-    (if *database-connection*
-       (begin
-         (set! *database-connection* pgsql-conn)
-         (fluid-let ((*ps-number* ps-number)
-                     (*page-pathname* pathname)
-                     (*page-key* page-key))
-           (thunk)))
-       (fluid-let ((*database-connection* pgsql-conn)
-                   (*user-name* (http-request-user-name))
-                   (*ps-number* ps-number)
-                   (*page-pathname* pathname)
-                   (*page-key* page-key))
-         (database-transaction thunk)))))
+(define (with-database-connection ps-number thunk)
+  (fluid-let ((*database-connection* (open-database-connection))
+             (*user-name* (http-request-user-name))
+             (*ps-number* ps-number)
+             (*page-key* (http-request-url)))
+    (let ((commit? #f))
+      (dynamic-wind (lambda ()
+                     (db-run-cmd "BEGIN"))
+                   (lambda ()
+                     (let ((v (thunk)))
+                       (set! commit? #t)
+                       v))
+                   (lambda ()
+                     (db-run-cmd (if commit? "COMMIT" "ROLLBACK")))))))
 
 (define (database-connection)
-  (let ((conn *database-connection*))
-    (if (pgsql-conn-open? conn)
-       conn
-       (let ((conn (open-pgsql-conn (get-db-open-args *page-pathname*))))
-         (set! pgsql-conn conn)
-         (set! *database-connection* conn)
-         conn))))
-
-(define (get-db-open-args pathname)
-  (string-append "dbname=" (get-db-name pathname)))
-
-(define (get-db-name pathname)
-  (let loop ((directory (directory-pathname pathname)))
-    (let ((pathname (merge-pathnames ".xdoc-db" directory)))
-      (if (file-exists? pathname)
-         (call-with-input-file pathname read-line)
-         (let ((path (pathname-directory directory)))
-           (if (pair? (cdr path))
-               (loop
-                (pathname-new-directory directory (except-last-pair path)))
-               default-db-name))))))
-\f
-(define (database-transaction thunk)
-  (let ((commit? #f))
-    (dynamic-wind (lambda ()
-                   (db-run-cmd "BEGIN"))
-                 (lambda ()
-                   (let ((v (thunk)))
-                     (set! commit? #t)
-                     v))
-                 (lambda ()
-                   (db-run-cmd (if commit? "COMMIT" "ROLLBACK"))))))
+  (if (not *database-connection*)
+      (error "No database connection available."))
+  (if (not (pgsql-conn-open? *database-connection*))
+      (set! *database-connection* (open-database-connection)))
+  *database-connection*)
+
+(define (open-database-connection)
+  (let ((name (url-binding-value (http-request-url) 'xdoc-db-name #t)))
+    (let ((p (assoc name database-connections)))
+      (if (and p (pgsql-conn-open? (cdr p)))
+         (cdr p)
+         (let ((connection (open-pgsql-conn (string-append "dbname=" name))))
+           (set! database-connections
+                 (cons (cons name connection)
+                       database-connections))
+           connection)))))
 
 (define (close-database)
-  (if pgsql-conn
-      (begin
-       (if (pgsql-conn-open? pgsql-conn)
-           (close-pgsql-conn pgsql-conn))
-       (set! pgsql-conn #f)
-       unspecific)))
+  (do () ((not (pair? database-connections)))
+    (let ((connection (cdar database-connections)))
+      (set! database-connections (cdr database-connections))
+      (if (pgsql-conn-open? connection)
+         (close-pgsql-conn connection)))))
 
 (define (db-run-query . strings)
   (let ((query (string-append (apply string-append strings) ";")))

diff --git a/v7/src/xdoc/xdoc.scm b/v7/src/xdoc/xdoc.scm
index 5f0d36a2d7ec8c4dc9c652816960207b27d39ed4..e9a1a692a6f3e3d60ed9c78560cbae50a0f6d18e 100644 (file)
--- a/v7/src/xdoc/xdoc.scm
+++ b/v7/src/xdoc/xdoc.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: xdoc.scm,v 1.1 2004/11/01 19:21:05 cph Exp $
+$Id: xdoc.scm,v 1.2 2004/11/26 15:17:27 cph Exp $
 
 Copyright 2003,2004 Massachusetts Institute of Technology
 
@@ -78,7 +78,7 @@ USA.
          0))))
 
 (define (with-xdoc-expansion-context ps-number pathname procedure)
-  (with-database-connection ps-number pathname
+  (with-database-connection ps-number
     (lambda ()
       (let ((environment (make-expansion-environment pathname)))
        (fluid-let ((*in-xdoc-context?* #t)