summaryrefslogtreecommitdiffstats
path: root/dbutil.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:25 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:25 -0800
commit8ffbc2df0fde83082610149d24e594c1cd879f4a (patch)
treea2be9aad5101c5e450ad141d15c514bc9c2a2963 /dbutil.scm
downloadslib-8ffbc2df0fde83082610149d24e594c1cd879f4a.tar.gz
slib-8ffbc2df0fde83082610149d24e594c1cd879f4a.zip
Import Upstream version 2a6upstream/2a6
Diffstat (limited to 'dbutil.scm')
-rw-r--r--dbutil.scm222
1 files changed, 222 insertions, 0 deletions
diff --git a/dbutil.scm b/dbutil.scm
new file mode 100644
index 0000000..ffaaf9d
--- /dev/null
+++ b/dbutil.scm
@@ -0,0 +1,222 @@
+;;; "dbutil.scm" relational-database-utilities
+; Copyright 1994, 1995 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.
+;
+;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
+;this software will be error-free, and I am under no obligation to
+;provide any services, by way of maintenance, update, or otherwise.
+;
+;3. In conjunction with products arising from the use of this
+;material, there shall be no use of my name in any advertising,
+;promotional, or sales literature without prior written consent in
+;each case.
+
+(require 'relational-database)
+
+(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:create-database path type)
+ (require type)
+ (let ((rdb (((make-relational-system (slib:eval type)) 'create-database)
+ path)))
+ (dbutil:define-tables
+ rdb
+ '(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 #f)
+ (parameter-name-translation *catalog-data* #f symbol #f)
+ (parameter-arity parameter-arity #f symbol #f)))
+ (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 default #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))
+ ())
+ '(*commands*
+ ((name symbol))
+ ((parameters parameter-list)
+ (parameter-names parameter-name-translation)
+ (procedure expression)
+ (documentation string))
+ ((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))))
+ (cond (fkname (let* ((fktab ((rdb 'open-table) fkname #f))
+ (p? (fktab 'get 1)))
+ (cond (dir (lambda (e) (and (dir e) (p? e))))
+ (else p?))))
+ (else dir))))))
+ "return procedure to check given domain name")
+
+ (add-domain
+ no-parameters
+ no-parameter-names
+ (lambda (rdb)
+ (((rdb 'open-table) '*domains-data* #t) 'row:insert))
+ "given the row describing it, add a domain")
+
+ (delete-domain
+ no-parameters
+ no-parameter-names
+ (lambda (rdb)
+ (((rdb 'open-table) '*domains-data* #t) 'row:remove))
+ "given its name, delete a domain"))))
+ (dbutil:wrap-command-interface rdb)))
+
+(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)
+ (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)))
+ (defaults (map slib:eval ((parameter-table 'get* 'default))))
+ (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 defaults dirs aliases)))))
+
+(define (dbutil: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))
+ (define open-table (rdb 'open-table))
+ (define table-exists? (rdb 'table-exists?))
+ (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)))
+ ((((rdb 'open-table) '*domains-data* #t) 'row:insert)
+ (list dname dname #f
+ (dom:typ ((ftab 'get 'domain-name) 1)) #f))))))
+ (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)))
+ ((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)
+ ((tab 'close-table))))
+ (else
+ (let* ((descname
+ (string->symbol (string-append "desc:" (symbol->string name))))
+ (tab (create-table descname))
+ (row:insert (tab 'row:insert))
+ (j 0))
+ (set! new-tables (cons name new-tables))
+ (for-each (lambda (des)
+ (set! j (+ 1 j))
+ (check-domain (cadr des))
+ (row:insert (list j #t (car des)
+ (if (null? (cddr des)) #f (caddr des))
+ (cadr des))))
+ prikeys)
+ (for-each (lambda (des)
+ (set! j (+ 1 j))
+ (check-domain (cadr des))
+ (row:insert (list j #f (car des)
+ (if (null? (cddr des)) #f (caddr des))
+ (cadr des))))
+ slots)
+ ((tab 'close-table))
+ (set! tab (create-table name descname))
+ (set! row:insert (tab 'row:insert))
+ (for-each row:insert data)
+ ((tab 'close-table))))))
+ (for-each (lambda (spec) (apply define-table spec)) spec-list))
+
+(define create-database dbutil:create-database)
+(define open-database! dbutil:open-database!)
+(define open-database dbutil:open-database)
+(define define-tables dbutil:define-tables)