Commit | Line | Data |
---|---|---|
9ddacf86 KN |
1 | ;;; "dbrowse.scm" relational-database-browser |
2 | ; Copyright 1996, 1997, 1998 Aubrey Jaffer | |
3 | ; | |
4 | ;Permission to copy this software, to redistribute it, and to use it | |
5 | ;for any purpose is granted, subject to the following restrictions and | |
6 | ;understandings. | |
7 | ; | |
8 | ;1. Any copy made of this software must include this copyright notice | |
9 | ;in full. | |
10 | ; | |
11 | ;2. I have made no warrantee or representation that the operation of | |
12 | ;this software will be error-free, and I am under no obligation to | |
13 | ;provide any services, by way of maintenance, update, or otherwise. | |
14 | ; | |
15 | ;3. In conjunction with products arising from the use of this | |
16 | ;material, there shall be no use of my name in any advertising, | |
17 | ;promotional, or sales literature without prior written consent in | |
18 | ;each case. | |
19 | ||
20 | (require 'database-utilities) | |
21 | (require 'printf) | |
22 | ||
23 | (define browse:db #f) | |
24 | ||
25 | (define (browse . args) | |
26 | (define table-name #f) | |
27 | (cond ((null? args)) | |
28 | ((procedure? (car args)) | |
29 | (set! browse:db (car args)) | |
30 | (set! args (cdr args))) | |
31 | ((string? (car args)) | |
32 | (set! browse:db (open-database (car args))) | |
33 | (set! args (cdr args)))) | |
34 | (cond ((null? args)) | |
35 | (else (set! table-name (car args)))) | |
36 | (let* ((open-table (browse:db 'open-table)) | |
37 | (catalog (and open-table (open-table '*catalog-data* #f)))) | |
38 | (cond ((not catalog) | |
39 | (slib:error 'browse "could not open catalog")) | |
40 | ((not table-name) | |
41 | (browse:display-dir '*catalog-data* catalog)) | |
42 | (else | |
43 | (let ((table (open-table table-name #f))) | |
44 | (cond (table (browse:display-table table-name table) | |
45 | (table 'close-table)) | |
46 | (else (slib:error 'browse "could not open table" | |
47 | table-name)))))))) | |
48 | ||
49 | (define (browse:display-dir table-name table) | |
50 | (printf "%s Tables:\\n" table-name) | |
51 | ((table 'for-each-row) | |
52 | (lambda (row) (printf "\\t%s\\n" (car row))))) | |
53 | ||
54 | (define (browse:display-table table-name table) | |
55 | (let* ((width 18) | |
56 | (dw (string-append "%-" (number->string width))) | |
57 | (dwp (string-append "%-" (number->string width) "." | |
58 | (number->string (+ -1 width)))) | |
59 | (dwp-string (string-append dwp "s")) | |
60 | (dwp-any (string-append dwp "a")) | |
61 | (dw-integer (string-append dw "d")) | |
62 | (underline (string-append (make-string (+ -1 width) #\=) " ")) | |
63 | (form "")) | |
64 | (printf "Table: %s\\n" table-name) | |
65 | (for-each (lambda (name) (printf dwp-string name)) | |
66 | (table 'column-names)) | |
67 | (newline) | |
68 | (for-each (lambda (foreign) (printf dwp-any foreign)) | |
69 | (table 'column-foreigns)) | |
70 | (newline) | |
71 | (for-each (lambda (domain) (printf dwp-string domain)) | |
72 | (table 'column-domains)) | |
73 | (newline) | |
74 | (for-each (lambda (type) | |
75 | (case type | |
76 | ((integer number uint base-id) | |
77 | (set! form (string-append form dw-integer))) | |
78 | ((boolean domain expression atom) | |
79 | (set! form (string-append form dwp-any))) | |
80 | ((string symbol) | |
81 | (set! form (string-append form dwp-string))) | |
82 | (else (slib:error 'browse:display-table "unknown type" type))) | |
83 | (printf dwp-string type)) | |
84 | (table 'column-types)) | |
85 | (newline) | |
86 | (set! form (string-append form "\\n")) | |
87 | (for-each (lambda (domain) (printf underline)) | |
88 | (table 'column-domains)) | |
89 | (newline) | |
90 | ((table 'for-each-row) | |
91 | (lambda (row) | |
92 | (apply printf form row))))) |