/usr/share/slib/dbcom.scm is in slib 3b1-3.1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 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)))))
|