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