summaryrefslogtreecommitdiffstats
path: root/dbutil.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:27 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:27 -0800
commitfa3f23105ddcf07c5900de47f19af43d1db1b597 (patch)
treeb2c6cce6b97698098f50cbc78c23fdc0f8d401ab /dbutil.scm
parentf24b9140d6f74804d5599ec225717d38ca443813 (diff)
downloadslib-fa3f23105ddcf07c5900de47f19af43d1db1b597.tar.gz
slib-fa3f23105ddcf07c5900de47f19af43d1db1b597.zip
Import Upstream version 2c3upstream/2c3
Diffstat (limited to 'dbutil.scm')
-rw-r--r--dbutil.scm83
1 files changed, 65 insertions, 18 deletions
diff --git a/dbutil.scm b/dbutil.scm
index e99b073..1ed84da 100644
--- a/dbutil.scm
+++ b/dbutil.scm
@@ -56,6 +56,19 @@
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)
@@ -71,9 +84,10 @@
(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)))
+ '((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*
@@ -94,6 +108,36 @@
((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)
@@ -110,26 +154,29 @@
(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))))))
+ (if fkname (let* ((fktab ((rdb 'open-table) fkname #f))
+ (p? (fktab 'get 1)))
+ (if dir (lambda (e) (and (dir e) (p? e))) p?))
+ dir)))))
"return procedure to check given domain name")
(add-domain
- no-parameters
- no-parameter-names
+ add-domain-params
+ add-domain-pnames
(lambda (rdb)
- (((rdb 'open-table) '*domains-data* #t) 'row:insert))
- "given the row describing it, add a domain")
+ (((rdb 'open-table) '*domains-data* #t) 'row:update))
+ "add a new domain")
(delete-domain
- no-parameters
- no-parameter-names
+ del-domain-params
+ del-domain-pnames
(lambda (rdb)
(((rdb 'open-table) '*domains-data* #t) 'row:remove))
- "given its name, delete a domain"))))
+ "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-command-server rdb command-table)
@@ -139,8 +186,8 @@
(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-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))
@@ -174,7 +221,7 @@
#f)))
((((rdb 'open-table) '*domains-data* #t) 'row:insert)
(list dname dname #f
- (dom:typ ((ftab 'get 'domain-name) 1)) #f))))))
+ (dom:typ ((ftab 'get 'domain-name) 1)) 1))))))
(define (define-table name prikeys slots data)
(cond
((table-exists? name)