diff options
Diffstat (limited to 'dbutil.scm')
| -rw-r--r-- | dbutil.scm | 74 |
1 files changed, 59 insertions, 15 deletions
@@ -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) |