summaryrefslogtreecommitdiffstats
path: root/dbutil.scm
diff options
context:
space:
mode:
Diffstat (limited to 'dbutil.scm')
-rw-r--r--dbutil.scm674
1 files changed, 435 insertions, 239 deletions
diff --git a/dbutil.scm b/dbutil.scm
index 248ec1d..5e5c86d 100644
--- a/dbutil.scm
+++ b/dbutil.scm
@@ -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)