diff options
Diffstat (limited to 'dbcom.scm')
| -rw-r--r-- | dbcom.scm | 215 |
1 files changed, 215 insertions, 0 deletions
diff --git a/dbcom.scm b/dbcom.scm new file mode 100644 index 0000000..428e3db --- /dev/null +++ b/dbcom.scm @@ -0,0 +1,215 @@ +;;; "dbcom.scm" embed commands in relational-database +; Copyright 1994, 1995, 1997, 2000, 2001 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 +;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 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. +; +;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 'common-list-functions) ;for position +(require 'relational-database) +(require 'databases) +;@ +(define (wrap-command-interface 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))) + (if com ((slib:eval com) wdb) (rdb command)))))) + (let ((init (wdb '*initialize*))) + (if (procedure? init) init wdb)))))) +;@ +(define (open-command-database! path . arg) + (define bt (apply open-database! path arg)) + (and bt (wrap-command-interface bt))) +;@ +(define (open-command-database path . arg) + (define bt (apply open-database path arg)) + (and bt (wrap-command-interface bt))) +;@ +(define (add-command-tables rdb) + (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))) + (define-tables + rdb + '(*parameter-columns* + *columns* + *columns* + ((1 #t index #f ordinal) + (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 ordinal)) + ()) + '(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 ordinal)) ;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 ordinal)) ;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 + dbcom: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))) + ((tab 'row:update) (cons 'type (cdr row)))) + (wrap-command-interface rdb)) +;@ +(define (define-*commands* rdb . cmd-defs) + (define defcmd (((rdb 'open-table) '*commands* #t) 'row:update)) + (for-each (lambda (def) + (define procname (caar def)) + (define args (cdar def)) + (define body (cdr def)) + (let ((comment (and (string? (car body)) (car body)))) + (define nbody (if comment (cdr body) body)) + (defcmd (list procname + 'no-parameters + 'no-parameter-names + `(lambda ,args ,@nbody) + (or comment ""))))) + cmd-defs)) + +;; Actually put into command table by add-command-tables +(define (dbcom: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 (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 (or (rdb 'domain-checker) (lambda (domain) + (lambda (domain) #t))) + 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))))) |