diff options
Diffstat (limited to 'dbutil.scm')
| -rw-r--r-- | dbutil.scm | 674 |
1 files changed, 435 insertions, 239 deletions
@@ -1,5 +1,5 @@ ;;; "dbutil.scm" relational-database-utilities -; Copyright 1994, 1995, 1997, 2000, 2001 Aubrey Jaffer +; Copyright 1994, 1995, 1997, 2000, 2001, 2002 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is @@ -8,7 +8,7 @@ ;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 +;2. I have made no warranty 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. ; @@ -17,226 +17,418 @@ ;promotional, or sales literature without prior written consent in ;each case. +(require 'common-list-functions) ;for nthcdr and butnthcdr (require 'relational-database) -(require 'common-list-functions) - -(define (db:base-type path) - 'alist-table) ; currently the only one. - -(define (dbutil:wrap-command-interface rdb) - (and rdb - (let* ((rdms:commands ((rdb 'open-table) '*commands* #f)) - (command:get - (and rdms:commands (rdms:commands 'get 'procedure)))) - (and command:get - (letrec ((wdb (lambda (command) - (let ((com (command:get command))) - (cond (com ((slib:eval com) wdb)) - (else (rdb command))))))) - (let ((init (wdb '*initialize*))) - (if (procedure? init) init wdb))))))) - -(define (dbutil:open-database! path . arg) - (let ((type (if (null? arg) (db:base-type path) (car arg)))) - (require type) - (dbutil:wrap-command-interface - (((make-relational-system (slib:eval type)) 'open-database) - path #t)))) - -(define (dbutil:open-database path . arg) - (let ((type (if (null? arg) (db:base-type path) (car arg)))) - (require type) - (dbutil:wrap-command-interface - (((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 'dynamic-wind) +(require 'transact) +(require-if 'compiling 'printf) ;used only by mdbm:report +(require-if 'compiling 'alist-table) + +;;@code{(require 'databases)} +;;@ftindex databases +;; +;;@noindent +;;This enhancement wraps a utility layer on @code{relational-database} +;;which provides: +;; +;;@itemize @bullet +;;@item +;;Identification of open databases by filename. +;;@item +;;Automatic sharing of open (immutable) databases. +;;@item +;;Automatic loading of base-table package when creating a database. +;;@item +;;Detection and automatic loading of the appropriate base-table package +;;when opening a database. +;;@item +;;Table and data definition from Scheme lists. +;;@end itemize + +;;;Each entry in mdbm:*databases* is a list of: + +;;; * database (procedure) +;;; * number of opens (integer) +;;; * type (symbol) +;;; * lock-certificate + +;;;Because of WRITE-DATABASE, database filenames can change, so we must +;;;have a global lock. +(define mdbm:*databases* (make-exchanger '())) +(define (mdbm:return-dbs dbs) + (if (mdbm:*databases* dbs) + (slib:error 'mdbm:*databases* 'double 'set!))) + +(define (mdbm:find-db? rdb dbs) + (and dbs + (do ((dbs dbs (cdr dbs))) + ((or (null? dbs) + (equal? ((caar dbs) 'filename) + (if (procedure? rdb) (rdb 'filename) rdb))) + (and (not (null? dbs)) + (if (and (procedure? rdb) + (not (eq? ((caar dbs) 'filename) (rdb 'filename)))) + (slib:error ((caar dbs) 'filename) 'open 'twice) + (car dbs))))))) + +(define (mdbm:remove-entry dbs entry) + (cond ((null? dbs) (slib:error 'mdbm:remove-entry 'not 'found entry)) + ((eq? entry (car dbs)) (cdr dbs)) + (else (cons (car dbs) (mdbm:remove-entry (cdr dbs) entry))))) + +;;@subsubheading Database Sharing + +;;@noindent +;;@dfn{Auto-sharing} refers to a call to the procedure +;;@code{open-database} returning an already open database (procedure), +;;rather than opening the database file a second time. +;; +;;@quotation +;;@emph{Note:} Databases returned by @code{open-database} do not include +;;wrappers applied by packages like @ref{Embedded Commands}. But +;;wrapped databases do work as arguments to these functions. +;;@end quotation +;; +;;@noindent +;;When a database is created, it is mutable by the creator and not +;;auto-sharable. A database opened mutably is also not auto-sharable. +;;But any number of readers can (open) share a non-mutable database file. + +;;@noindent +;;This next set of procedures mirror the whole-database methods in +;;@ref{Database Operations}. Except for @code{create-database}, each +;;procedure will accept either a filename or database procedure for its +;;first argument. + +(define (mdbm:try-opens filename mutable?) + (define (try base) + (let ((rdb (base 'open-database))) + (and rdb (rdb filename mutable?)))) + (define certificate (and mutable? (file-lock! filename))) + (define (loop bti) + (define rdb (try (cadar bti))) + (cond ((procedure? rdb) (list rdb 1 (caar bti) certificate)) + ((null? (cdr bti)) #f) + (else (loop (cdr bti))))) + (if (null? *base-table-implementations*) (require 'alist-table)) + (cond ((and (not (and mutable? (not certificate))) + (loop *base-table-implementations*))) + ((memq 'alist-table *base-table-implementations*) #f) + ((let () + (require 'alist-table) + (loop (list (car *base-table-implementations*))))) + (else #f))) + +(define (mdbm:open-type filename type mutable?) + (require type) + (let ((certificate (and mutable? (file-lock! filename)))) + (and (not (and mutable? (not certificate))) + (let* ((sys (cadr (assq type *base-table-implementations*))) + (open (and sys (sys 'open-database))) + (ndb (and open (open filename mutable?)))) + (and ndb (list ndb 1 type certificate)))))) + +;;@args filename base-table-type +;;@1 should be a string naming a file; or @code{#f}. @2 must be a +;;symbol naming a feature which can be passed to @code{require}. @0 +;;returns a new, open relational database (with base-table type @2) +;;associated with @1, or a new ephemeral database if @1 is @code{#f}. +;; +;;@code{create-database} is the only run-time use of require in SLIB +;;which crosses module boundaries. When @2 is @code{require}d by @0; it +;;adds an association of @2 with its @dfn{relational-system} procedure +;;to @var{mdbm:*databases*}. +;; +;;alist-table is the default base-table type: +;; +;;@example +;;(require 'databases) +;;(define my-rdb (create-database "my.db" 'alist-table)) +;;@end example +(define (create-database filename type) (require type) - (let ((rdb (((make-relational-system (slib:eval type)) 'create-database) - path))) - (dbutil:define-tables - rdb - '(type - ((name symbol)) - () - ((atom) - (symbol) - (string) - (number) - (money) - (date-time) - (boolean) - (foreign-key) - (expression) - (virtual))) - '(parameter-arity - ((name symbol)) - ((predicate? expression) - (procedure expression)) - ((single (lambda (a) (and (pair? a) (null? (cdr a)))) car) - (optional - (lambda (lambda (a) (or (null? a) (and (pair? a) (null? (cdr a)))))) - identity) - (boolean - (lambda (a) (or (null? a) - (and (pair? a) (null? (cdr a)) (boolean? (car a))))) - (lambda (a) (if (null? a) #f (car a)))) - (nary (lambda (a) #t) identity) - (nary1 (lambda (a) (not (null? a))) identity)))) - (for-each (((rdb 'open-table) '*domains-data* #t) 'row:insert) - '((parameter-list *catalog-data* #f symbol 1) - (parameter-name-translation *catalog-data* #f symbol 1) - (parameter-arity parameter-arity #f symbol 1) - (table *catalog-data* #f atom 1))) - (dbutil:define-tables - rdb - '(*parameter-columns* - *columns* - *columns* - ((1 #t index #f uint) - (2 #f name #f symbol) - (3 #f arity #f parameter-arity) - (4 #f domain #f domain) - (5 #f defaulter #f expression) - (6 #f expander #f expression) - (7 #f documentation #f string))) - '(no-parameters - *parameter-columns* - *parameter-columns* - ()) - '(no-parameter-names - ((name string)) - ((parameter-index uint)) - ()) - '(add-domain-params - *parameter-columns* - *parameter-columns* - ((1 domain-name single atom #f #f "new domain name") - (2 foreign-table optional table #f #f - "if present, domain-name must be existing key into this table") - (3 domain-integrity-rule optional expression #f #f - "returns #t if single argument is good") - (4 type-id single type #f #f "base type of new domain") - (5 type-param optional expression #f #f - "which (key) field of the foreign-table") - )) - '(add-domain-pnames - ((name string)) - ((parameter-index uint)) ;should be add-domain-params - ( - ("n" 1) ("name" 1) - ("f" 2) ("foreign (key) table" 2) - ("r" 3) ("domain integrity rule" 3) - ("t" 4) ("type" 4) - ("p" 5) ("type param" 5) - )) - '(del-domain-params - *parameter-columns* - *parameter-columns* - ((1 domain-name single domain #f #f "domain name"))) - '(del-domain-pnames - ((name string)) - ((parameter-index uint)) ;should be del-domain-params - (("n" 1) ("name" 1))) - '(*commands* - ((name symbol)) - ((parameters parameter-list) - (parameter-names parameter-name-translation) - (procedure expression) - (documentation string)) - ((domain-checker - no-parameters - no-parameter-names - dbutil:check-domain - "return procedure to check given domain name") - - (add-domain - add-domain-params - add-domain-pnames - (lambda (rdb) - (((rdb 'open-table) '*domains-data* #t) 'row:update)) - "add a new domain") - - (delete-domain - del-domain-params - del-domain-pnames - (lambda (rdb) - (((rdb 'open-table) '*domains-data* #t) 'row:remove)) - "delete a domain")))) - (let* ((tab ((rdb 'open-table) '*domains-data* #t)) - (row ((tab 'row:retrieve) 'type))) - (set-car! (cdr row) 'type) - ((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)) - (parameter-names - ((rdb 'open-table) (row-ref command:row 'parameter-names) #f)) - (comval ((slib:eval (row-ref command:row 'procedure)) rdb)) - (options ((parameter-table 'get* 'name))) - (positions ((parameter-table 'get* 'index))) - (arities ((parameter-table 'get* 'arity))) - (defaulters (map slib:eval ((parameter-table 'get* 'defaulter)))) - (domains ((parameter-table 'get* 'domain))) - (types (map (((rdb 'open-table) '*domains-data* #f) 'get 'type-id) - domains)) - (dirs (map (rdb 'domain-checker) domains)) - (aliases - (map list ((parameter-names 'get* 'name)) - (map (parameter-table 'get 'name) - ((parameter-names 'get* 'parameter-index)))))) - (command-callback comname comval options positions - arities types defaulters dirs aliases))))) - -(define (dbutil:define-tables rdb . spec-list) + (let ((dbs #f) + (certificate (and filename (file-lock! filename)))) + (and + (or certificate (not filename)) + (dynamic-wind + (lambda () (set! dbs (mdbm:*databases* #f))) + (lambda () + (define entry (mdbm:find-db? filename dbs)) + (cond (entry (slib:warn 'close ((car entry) 'filename) + 'before 'create-database) #f) + (else + (let ((pair (assq type *base-table-implementations*))) + (define ndb (and pair (((cadr pair) 'create-database) + filename))) + (if (and ndb dbs) + (set! dbs (cons (list ndb 1 type certificate) dbs))) + ndb)))) + (lambda () (and dbs (mdbm:return-dbs dbs))))))) + +;;@noindent +;;Only @code{alist-table} and base-table modules which have been +;;@code{require}d will dispatch correctly from the +;;@code{open-database} procedures. Therefore, either pass two +;;arguments to @code{open-database}, or require the base-table of your +;;database file uses before calling @code{open-database} with one +;;argument. + +;;@args rdb base-table-type +;;Returns @emph{mutable} open relational database or #f. +(define (open-database! filename . type) + (set! type (and (not (null? type)) (car type))) + (let ((dbs #f)) + (dynamic-wind + (lambda () (set! dbs (mdbm:*databases* #f))) + (lambda () + (cond ((and (procedure? filename) (not (filename 'delete-table))) + (slib:warn (filename 'filename) 'not 'mutable) #f) + ((mdbm:find-db? filename dbs) + (cond ((procedure? filename) filename) + (else (slib:warn filename 'already 'open) #f))) + (else (let ((entry (if type + (mdbm:open-type filename type #t) + (mdbm:try-opens filename #t)))) + (cond (entry (and dbs (set! dbs (cons entry dbs))) + (car entry)) + (else #f)))))) + (lambda () (and dbs (mdbm:return-dbs dbs)))))) + +;;@args rdb base-table-type +;;Returns an open relational database associated with @1. The +;;database will be opened with base-table type @2). +;; +;;@args rdb +;;Returns an open relational database associated with @1. +;;@0 will attempt to deduce the correct base-table-type. +(define (open-database rdb . type) + (set! type (and (not (null? type)) (car type))) + (let ((dbs #f)) + (dynamic-wind + (lambda () (set! dbs (mdbm:*databases* #f))) + (lambda () + (define entry (mdbm:find-db? rdb dbs)) + (and entry (set! rdb (car entry))) + (cond ((and entry type (not (eqv? (caddr entry) type))) + (slib:warn (rdb 'filename) 'type type '<> (caddr entry)) #f) + ((and (procedure? rdb) (rdb 'delete-table)) + (slib:warn (rdb 'filename) 'mutable) #f) + (entry (set-car! (cdr entry) (+ 1 (cadr entry))) rdb) + (else + (set! entry + (cond ((procedure? rdb) (list rdb 1 type #f)) + (type (mdbm:open-type rdb type #f)) + (else (mdbm:try-opens rdb #f)))) + (cond (entry (and dbs (set! dbs (cons entry dbs))) + (car entry)) + (else #f))))) + (lambda () (and dbs (mdbm:return-dbs dbs)))))) + +;;@body +;;Writes the mutable relational-database @1 to @2. +(define (write-database rdb filename) + (let ((dbs #f)) + (dynamic-wind + (lambda () (set! dbs (mdbm:*databases* #f))) + (lambda () + (define entry (mdbm:find-db? rdb dbs)) + (and entry (set! rdb (car entry))) + (cond ((and (not entry) (procedure? rdb)) + (set! entry (list rdb 1 #f (file-lock! filename))) + (and dbs (set! dbs (cons entry dbs))))) + (cond ((not entry) #f) + ((and (not (equal? filename (rdb 'filename))) + (mdbm:find-db? filename dbs)) + (slib:warn filename 'already 'open) #f) + (else (let ((dbwrite (rdb 'write-database))) + (and dbwrite (dbwrite filename)))))) + (lambda () (and dbs (mdbm:return-dbs dbs)))))) + +;;@args rdb +;;Writes the mutable relational-database @1 to the filename it was +;;opened with. +(define (sync-database rdb) + (let ((dbs #f)) + (dynamic-wind + (lambda () (set! dbs (mdbm:*databases* #f))) + (lambda () + (define entry (mdbm:find-db? rdb dbs)) + (and entry (set! rdb (car entry))) + (cond ((and (not entry) (procedure? rdb)) + (set! entry (list rdb 1 #f (file-lock! (rdb 'filename)))) + (and dbs (set! dbs (cons entry dbs))))) + (cond (entry (let ((db-op (rdb 'sync-database))) + (and db-op (db-op)))) + (else #f))) + (lambda () (and dbs (mdbm:return-dbs dbs)))))) + +;;@args rdb +;;Syncs @1 and makes it immutable. +(define (solidify-database rdb) ; + (let ((dbs #f)) + (dynamic-wind + (lambda () (set! dbs (mdbm:*databases* #f))) + (lambda () + (define entry (mdbm:find-db? rdb dbs)) + (define certificate #f) + (cond (entry (set! rdb (car entry)) + (set! certificate (cadddr entry))) + ((procedure? rdb) + (set! entry (list rdb 1 #f (file-lock! (rdb 'filename)))) + (and dbs (set! dbs (cons entry dbs))) + (set! certificate (cadddr entry)))) + (cond ((or (not certificate) (not (procedure? rdb))) #f) + (else + (let* ((filename (rdb 'filename)) + (dbsolid (rdb 'solidify-database)) + (ret (and dbsolid (dbsolid)))) + (if (file-unlock! filename certificate) + (set-car! (cdddr entry) #f) + (slib:warn 'file-unlock! filename certificate 'failed)) + ret)))) + (lambda () (and dbs (mdbm:return-dbs dbs)))))) + +;;@body +;;@1 will only be closed when the count of @code{open-database} - @0 +;;calls for @1 (and its filename) is 0. @0 returns #t if successful; +;;and #f otherwise. +(define (close-database rdb) + (let ((dbs #f)) + (dynamic-wind + (lambda () (set! dbs (mdbm:*databases* #f))) + (lambda () + (define entry (mdbm:find-db? rdb dbs)) + (define certificate #f) + (and entry (set! rdb (car entry))) + (and (procedure? rdb) + (set! certificate (or (and entry (cadddr entry)) + (and (rdb 'filename) + (file-lock! (rdb 'filename)))))) + (cond ((and entry (not (eqv? 1 (cadr entry)))) + (set-car! (cdr entry) (+ -1 (cadr entry))) + #f) + ((or (not certificate) (not (procedure? rdb))) + #f) + (else + (let* ((filename (rdb 'filename)) + (dbclose (rdb 'close-database)) + (ret (and dbclose (dbclose)))) + (if (not (file-unlock! filename certificate)) + (slib:warn 'file-unlock! filename certificate 'failed)) + (cond ((not dbclose) (slib:warn 'database? rdb)) + ((not entry)) + (dbs (set! dbs (mdbm:remove-entry dbs entry)))) + ret)))) + (lambda () (and dbs (mdbm:return-dbs dbs)))))) + +;;@body +;;Prints a table of open database files. The columns are the +;;base-table type, number of opens, @samp{!} for mutable, the +;;filename, and the lock certificate (if locked). +(define (mdbm:report) + (require 'printf) + (let ((dbs #f)) + (dynamic-wind + (lambda () (set! dbs (mdbm:*databases* #f))) + (lambda () + (cond (dbs (for-each (lambda (entry) + (printf "%15s %03d %1s %s %s\\n" + (or (caddr entry) "?") + (cadr entry) + (if ((car entry) 'delete-table) '! "") + (or ((car entry) 'filename) '-) + (or (cadddr entry) ""))) + dbs)) + (else (printf "%s lock broken.\\n" 'mdbm:*databases*)))) + (lambda () (and dbs (mdbm:return-dbs dbs)))))) +;;@example +;;(mdbm:report) +;;@print{} +;; alist-table 003 /usr/local/lib/slib/clrnamdb.scm +;; alist-table 001 ! sdram.db jaffer@@aubrey.jaffer.3166:1038628199 +;;@end example + + +;;@subsubheading Opening Tables + +;;@body +;;@1 must be a relational database and @2 a symbol. +;; +;;@0 returns a "methods" procedure for an existing relational table in +;;@1 if it exists and can be opened for reading, otherwise returns +;;@code{#f}. +(define (open-table rdb table-name) + ((rdb 'open-table) table-name #f)) + +;;@body +;;@1 must be a relational database and @2 a symbol. +;; +;;@0 returns a "methods" procedure for an existing relational table in +;;@1 if it exists and can be opened in mutable mode, otherwise returns +;;@code{#f}. +(define (open-table! rdb table-name) + ((rdb 'open-table) table-name #t)) + + +;;@subsubheading Defining Tables + +;;@body +;;Adds the domain rows @2 @dots{} to the @samp{*domains-data*} table +;;in @1. The format of the row is given in @ref{Catalog +;;Representation}. +;; +;;@example +;;(define-domains rdb '(permittivity #f complex? c64 #f)) +;;@end example +(define (define-domains rdb . row5) + (define add-domain (((rdb 'open-table) '*domains-data* #t) 'row:update)) + (for-each add-domain row5)) + +;;@body +;;Use @code{define-domains} instead. +(define (add-domain rdb row5) + ((((rdb 'open-table) '*domains-data* #t) 'row:update) + row5)) + +;;@args rdb spec-0 @dots{} +;;Adds tables as specified in @var{spec-0} @dots{} to the open +;;relational-database @1. Each @var{spec} has the form: +;; +;;@lisp +;;(@r{<name>} @r{<descriptor-name>} @r{<descriptor-name>} @r{<rows>}) +;;@end lisp +;;or +;;@lisp +;;(@r{<name>} @r{<primary-key-fields>} @r{<other-fields>} @r{<rows>}) +;;@end lisp +;; +;;where @r{<name>} is the table name, @r{<descriptor-name>} is the symbol +;;name of a descriptor table, @r{<primary-key-fields>} and +;;@r{<other-fields>} describe the primary keys and other fields +;;respectively, and @r{<rows>} is a list of data rows to be added to the +;;table. +;; +;;@r{<primary-key-fields>} and @r{<other-fields>} are lists of field +;;descriptors of the form: +;; +;;@lisp +;;(@r{<column-name>} @r{<domain>}) +;;@end lisp +;;or +;;@lisp +;;(@r{<column-name>} @r{<domain>} @r{<column-integrity-rule>}) +;;@end lisp +;; +;;where @r{<column-name>} is the column name, @r{<domain>} is the domain +;;of the column, and @r{<column-integrity-rule>} is an expression whose +;;value is a procedure of one argument (which returns @code{#f} to signal +;;an error). +;; +;;If @r{<domain>} is not a defined domain name and it matches the name of +;;this table or an already defined (in one of @var{spec-0} @dots{}) single +;;key field table, a foreign-key domain will be created for it. +(define (define-tables rdb . spec-list) (define new-tables '()) (define dom:typ (((rdb 'open-table) '*domains-data* #f) 'get 4)) (define create-table (rdb 'create-table)) @@ -245,26 +437,25 @@ (define (check-domain dname) (cond ((dom:typ dname)) ((member dname new-tables) - (let* ((ftab (open-table - (string->symbol - (string-append "desc:" (symbol->string dname))) - #f))) + (let ((ftab (open-table + (string->symbol + (string-append "desc:" (symbol->string dname))) + #f))) ((((rdb 'open-table) '*domains-data* #t) 'row:insert) (list dname dname #f (dom:typ ((ftab 'get 'domain-name) 1)) 1)))))) (define (define-table name prikeys slots data) (cond ((table-exists? name) - (let* ((tab (open-table name #t)) - (row:update (tab 'row:update))) - (for-each row:update data))) + (let ((tab (open-table name #t))) + ((tab 'row:update*) data) + ((tab 'close-table)))) ((and (symbol? prikeys) (eq? prikeys slots)) (cond ((not (table-exists? slots)) (slib:error "Table doesn't exist:" slots))) (set! new-tables (cons name new-tables)) - (let* ((tab (create-table name slots)) - (row:insert (tab 'row:insert))) - (for-each row:insert data) + (let ((tab (create-table name slots))) + ((tab 'row:insert*) data) ((tab 'close-table)))) (else (let* ((descname @@ -289,12 +480,22 @@ slots) ((tab 'close-table)) (set! tab (create-table name descname)) - (set! row:insert (tab 'row:insert)) - (for-each row:insert data) + ((tab 'row:insert*) data) ((tab 'close-table)))))) (for-each (lambda (spec) (apply define-table spec)) spec-list)) -(define (dbutil:list-table-definition rdb table-name) + +;;@subsubheading Listing Tables + +;;@body +;;If symbol @2 exists in the open relational-database +;;@1, then returns a list of the table-name, its primary key names +;;and domains, its other key names and domains, and the table's records +;;(as lists). Otherwise, returns #f. +;; +;;The list returned by @0, when passed as an +;;argument to @code{define-tables}, will recreate the table. +(define (list-table-definition rdb table-name) (cond (((rdb 'table-exists?) table-name) (let* ((table ((rdb 'open-table) table-name #f)) (prilimit (table 'primary-limit)) @@ -306,9 +507,4 @@ (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) +;;(trace-all "/home/jaffer/slib/dbutil.scm") (untrace define-tables) |