summaryrefslogtreecommitdiffstats
path: root/dbrowse.scm
diff options
context:
space:
mode:
Diffstat (limited to 'dbrowse.scm')
-rw-r--r--dbrowse.scm98
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)))))