summaryrefslogtreecommitdiffstats
path: root/dbcom.scm
diff options
context:
space:
mode:
Diffstat (limited to 'dbcom.scm')
-rw-r--r--dbcom.scm215
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)))))