summaryrefslogtreecommitdiffstats
path: root/dbutil.scm
diff options
context:
space:
mode:
Diffstat (limited to 'dbutil.scm')
-rw-r--r--dbutil.scm74
1 files changed, 59 insertions, 15 deletions
diff --git a/dbutil.scm b/dbutil.scm
index 1ed84da..248ec1d 100644
--- a/dbutil.scm
+++ b/dbutil.scm
@@ -1,9 +1,9 @@
;;; "dbutil.scm" relational-database-utilities
-; Copyright 1994, 1995, 1997 Aubrey Jaffer
+; Copyright 1994, 1995, 1997, 2000, 2001 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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, 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.
@@ -50,6 +50,18 @@
(((make-relational-system (slib:eval type)) 'open-database)
path #f))))
+(define (dbutil:check-domain rdb)
+ (let* ((ro:domains ((rdb 'open-table) '*domains-data* #f))
+ (ro:get-dir (ro:domains 'get 'domain-integrity-rule))
+ (ro:for-tab (ro:domains 'get 'foreign-table)))
+ (lambda (domain)
+ (let ((fkname (ro:for-tab domain))
+ (dir (slib:eval (ro:get-dir domain))))
+ (if fkname (let* ((fktab ((rdb 'open-table) fkname #f))
+ (p? (fktab 'get 1)))
+ (if dir (lambda (e) (and (dir e) (p? e))) p?))
+ dir)))))
+
(define (dbutil:create-database path type)
(require type)
(let ((rdb (((make-relational-system (slib:eval type)) 'create-database)
@@ -147,17 +159,7 @@
((domain-checker
no-parameters
no-parameter-names
- (lambda (rdb)
- (let* ((ro:domains ((rdb 'open-table) '*domains-data* #f))
- (ro:get-dir (ro:domains 'get 'domain-integrity-rule))
- (ro:for-tab (ro:domains 'get 'foreign-table)))
- (lambda (domain)
- (let ((fkname (ro:for-tab domain))
- (dir (slib:eval (ro:get-dir domain))))
- (if fkname (let* ((fktab ((rdb 'open-table) fkname #f))
- (p? (fktab 'get 1)))
- (if dir (lambda (e) (and (dir e) (p? e))) p?))
- dir)))))
+ dbutil:check-domain
"return procedure to check given domain name")
(add-domain
@@ -179,12 +181,40 @@
((tab 'row:update) row))
(dbutil:wrap-command-interface rdb)))
+(define (make-defaulter arity type)
+ `(lambda (pl)
+ ',(case arity
+ ((optional nary) '())
+ ((boolean) #f)
+ ((single nary1)
+ (case type
+ ((string) '(""))
+ ((symbol) '(nil))
+ ((number) '(0))
+ (else '(#f))))
+ (else (slib:error 'make-defaulter 'unknown 'arity arity)))))
+
+(define (get-foreign-choices tab)
+ (define dlst ((tab 'get* 1)))
+ (do ((dlst dlst (cdr dlst))
+ (vlst (if (memq 'visible-name (tab 'column-names))
+ ((tab 'get* 'visible-name))
+ dlst)
+ (cdr vlst))
+ (out '() (if (member (car dlst) (cdr dlst))
+ out
+ (cons (list (car dlst) (car vlst)) out))))
+ ((null? dlst) out)))
+
(define (make-command-server rdb command-table)
(let* ((comtab ((rdb 'open-table) command-table #f))
(names (comtab 'column-names))
(row-ref (lambda (row name) (list-ref row (position name names))))
(comgetrow (comtab 'row:retrieve)))
(lambda (comname command-callback)
+ (cond ((not comname) (set! comname '*default*)))
+ (cond ((not (comgetrow comname))
+ (slib:error 'command 'not 'known: comname)))
(let* ((command:row (comgetrow comname))
(parameter-table
((rdb 'open-table) (row-ref command:row 'parameters) #f))
@@ -264,7 +294,21 @@
((tab 'close-table))))))
(for-each (lambda (spec) (apply define-table spec)) spec-list))
+(define (dbutil:list-table-definition rdb table-name)
+ (cond (((rdb 'table-exists?) table-name)
+ (let* ((table ((rdb 'open-table) table-name #f))
+ (prilimit (table 'primary-limit))
+ (coldefs (map list
+ (table 'column-names)
+ (table 'column-domains))))
+ (list table-name
+ (butnthcdr prilimit coldefs)
+ (nthcdr prilimit coldefs)
+ ((table 'row:retrieve*)))))
+ (else #f)))
+
(define create-database dbutil:create-database)
(define open-database! dbutil:open-database!)
(define open-database dbutil:open-database)
(define define-tables dbutil:define-tables)
+(define list-table-definition dbutil:list-table-definition)