Import Upstream version 2a6upstream/2a6

1 files changed, 98 insertions, 0 deletions

diff --git a/dbrowse.scm b/dbrowse.scm
new file mode 100644
index 0000000..aaa4635
--- /dev/null
+++ b/dbrowse.scm
@@ -0,0 +1,98 @@
+;;; "dbrowse.scm" relational-database-browser
+; Copyright 1996 Aubrey Jaffer
+;
+;Permission to copy this software, to redistribute it, and to use it
+;for any purpose is granted, subject to the following restrictions and
+;understandings.
+;
+;1.  Any copy made of this software must include this copyright notice
+;in full.
+;
+;2.  I have made no warrantee or representation that the operation of
+;this software will be error-free, and I am under no obligation to
+;provide any services, by way of maintenance, update, or otherwise.
+;
+;3.  In conjunction with products arising from the use of this
+;material, there shall be no use of my name in any advertising,
+;promotional, or sales literature without prior written consent in
+;each case.
+
+(require 'database-utilities)
+(require 'printf)
+
+(define browse:db #f)
+
+(define (browse . args)
+  (define table-name '*catalog-data*)
+  (cond ((null? args))
+	((procedure? (car args))
+	 (set! browse:db (car args))
+	 (set! args (cdr args)))
+	((string? (car args))
+	 (set! browse:db (open-database (car args)))
+	 (set! args (cdr args))))
+  (cond ((null? args))
+	(else (set! table-name (car args))))
+  (let* ((open-table (browse:db 'open-table))
+	 (catalog (and open-table (open-table '*catalog-data* #f))))
+    (cond ((not catalog)
+	   (slib:error 'browse "could not open catalog"))
+	  ((eq? table-name '*catalog-data*)
+	   (browse:display-dir '*catalog-data* catalog))
+	  (else
+	   (let ((table (open-table table-name #f)))
+	     (cond (table (browse:display-table table-name table)
+			  (table 'close-table))
+		   (else (slib:error 'browse "could not open table"
+				     table-name))))))))
+
+(define (browse:display-dir table-name table)
+  (printf "%s Tables:
+" table-name)
+  ((table 'for-each-row)
+   (lambda (row)
+     (printf "	%s
+"
+	     (car row)))))
+
+(define (browse:display-table table-name table)
+  (let* ((width 18)
+	 (dw (string-append "%-" (number->string width)))
+	 (dwp (string-append "%-" (number->string width) "."
+			     (number->string (+ -1 width))))
+	 (dwp-string (string-append dwp "s"))
+	 (dwp-any (string-append dwp "a"))
+	 (dw-integer (string-append dw "d"))
+	 (underline (string-append (make-string (+ -1 width) #\=) " "))
+	 (form ""))
+    (printf "Table: %s
+" table-name)
+    (for-each (lambda (name) (printf dwp-string name))
+	      (table 'column-names))
+    (newline)
+    (for-each (lambda (foreign) (printf dwp-any foreign))
+	      (table 'column-foreigns))
+    (newline)
+    (for-each (lambda (domain) (printf dwp-string domain))
+	      (table 'column-domains))
+    (newline)
+    (for-each (lambda (type)
+		(case type
+		  ((integer number uint base-id)
+		   (set! form (string-append form dw-integer)))
+		  ((boolean domain expression atom)
+		   (set! form (string-append form dwp-any)))
+		  ((string symbol)
+		   (set! form (string-append form dwp-string)))
+		  (else (slib:error 'browse:display-table "unknown type" type)))
+		(printf dwp-string type))
+	      (table 'column-types))
+    (newline)
+    (set! form (string-append form "
+"))
+    (for-each (lambda (domain) (printf underline))
+	      (table 'column-domains))
+    (newline)
+    ((table 'for-each-row)
+     (lambda (row)
+       (apply printf form row)))))