summaryrefslogtreecommitdiffstats
path: root/rdms.scm
diff options
context:
space:
mode:
Diffstat (limited to 'rdms.scm')
-rw-r--r--rdms.scm598
1 files changed, 598 insertions, 0 deletions
diff --git a/rdms.scm b/rdms.scm
new file mode 100644
index 0000000..0fd4a2c
--- /dev/null
+++ b/rdms.scm
@@ -0,0 +1,598 @@
+;;; "rdms.scm" rewrite 6 - the saga continues
+; Copyright 1994 Aubrey Jaffer
+;
+;Permission to copy this software, to redistribute it, 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 warrantee 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.
+
+(define rdms:catalog-name '*catalog-data*)
+(define rdms:domains-name '*domains-data*)
+(define rdms:columns-name '*columns*)
+
+(define catalog:init-cols
+ '((1 #t table-name #f atom)
+ (2 #f column-limit #f uint)
+ (3 #f coltab-name #f atom)
+ (4 #f bastab-id #f base-id)
+ (5 #f user-integrity-rule #f expression)
+ (6 #f view-procedure #f expression)))
+
+(define catalog:column-limit-pos 2)
+(define catalog:coltab-name-pos 3)
+(define catalog:bastab-id-pos 4)
+(define catalog:integrity-rule-pos 5)
+(define catalog:view-proc-pos 6)
+
+(define columns:init-cols
+ '((1 #t column-number #f uint)
+ (2 #f primary-key? #f boolean)
+ (3 #f column-name #f symbol)
+ (4 #f column-integrity-rule #f expression)
+ (5 #f domain-name #f domain)))
+
+(define columns:primary?-pos 2)
+(define columns:name-pos 3)
+(define columns:integrity-rule-pos 4)
+(define columns:domain-name-pos 5)
+
+(define domains:init-cols
+ '((1 #t domain-name #f atom)
+ (2 #f foreign-table #f atom)
+ (3 #f domain-integrity-rule #f expression)
+ (4 #f type-id #f type)
+ (5 #f type-param #f expression)))
+
+(define domains:foreign-pos 2)
+(define domains:integrity-rule-pos 3)
+(define domains:type-id-pos 4)
+(define domains:type-param-pos 5)
+
+(define domains:init-data
+ `((atom #f
+ (lambda (x) (or (not x) (symbol? x) (number? x)))
+ atom
+ #f)
+ (type #f
+ #f ;type checked when openning
+ symbol
+ #f)
+ (base-id #f
+ (lambda (x) (or (symbol? x) (number? x)))
+ base-id
+ #f)
+ (uint #f
+ (lambda (x)
+ (and (number? x)
+ (integer? x)
+ (not (negative? x))))
+ integer
+ #f)
+ (expression #f #f expression #f)
+ (boolean #f boolean? boolean #f)
+ (symbol #f symbol? symbol #f)
+ (string #f string? string #f)
+ (domain ,rdms:domains-name #f atom #f)))
+
+(define (rdms:warn identifier msg obj)
+ (display identifier) (display #\ ) (display msg) (write obj) (newline))
+(define rdms:error slib:error)
+
+(define (make-relational-system base)
+ (define basic
+ (lambda (name)
+ (let ((meth (base name)))
+ (cond ((not meth) (rdms:error 'make-relational-system
+ "essential method missing for:" name)))
+ meth)))
+
+ (define (desc-row-type row)
+ (let ((domain (assq (car (cddddr row)) domains:init-data)))
+ (and domain (cadddr domain))))
+
+ (let ((make-base (base 'make-base))
+ (open-base (basic 'open-base))
+ (write-base (base 'write-base))
+ (sync-base (base 'sync-base))
+ (close-base (basic 'close-base))
+ (base:supported-type? (basic 'supported-type?))
+ (base:supported-key-type? (basic 'supported-key-type?))
+ (base:make-table (base 'make-table))
+ (base:open-table (basic 'open-table))
+ (base:kill-table (base 'kill-table))
+ (present? (basic 'present?))
+ (base:ordered-for-each-key (basic 'ordered-for-each-key))
+ (base:for-each-primary-key (basic 'for-each-key))
+ (base:map-primary-key (basic 'map-key))
+ (base:catalog-id (basic 'catalog-id))
+ (cat:keyify-1 ((basic 'make-keyifier-1)
+ (desc-row-type (assv 1 catalog:init-cols))))
+ (itypes
+ (lambda (rows)
+ (map (lambda (row)
+ (let ((domrow (assq (car (cddddr row)) domains:init-data)))
+ (cond (domrow (cadddr domrow))
+ (else (rdms:error 'itypes "type not found for:"
+ (car (cddddr row)))))))
+ rows))))
+
+ (define (init-tab lldb id descriptor rows)
+ (let ((han (base:open-table lldb id 1 (itypes descriptor)))
+ (keyify-1
+ ((base 'make-keyifier-1) (desc-row-type (assv 1 descriptor))))
+ (putter ((basic 'make-putter) 1 (itypes descriptor))))
+ (for-each (lambda (row) (putter han (keyify-1 (car row)) (cdr row)))
+ rows)))
+
+ (define cat:get-row
+ (let ((cat:getter ((basic 'make-getter) 1 (itypes catalog:init-cols))))
+ (lambda (bastab key)
+ (cat:getter bastab (cat:keyify-1 key)))))
+
+ (define dom:get-row
+ (let ((dom:getter ((basic 'make-getter) 1 (itypes domains:init-cols)))
+ (dom:keyify-1 ((basic 'make-keyifier-1)
+ (desc-row-type (assv 1 domains:init-cols)))))
+ (lambda (bastab key)
+ (dom:getter bastab (dom:keyify-1 key)))))
+
+ (define des:get-row
+ (let ((des:getter ((basic 'make-getter) 1 (itypes columns:init-cols)))
+ (des:keyify-1 ((basic 'make-keyifier-1)
+ (desc-row-type (assv 1 columns:init-cols)))))
+ (lambda (bastab key)
+ (des:getter bastab (des:keyify-1 key)))))
+
+ (define (create-database filename)
+ (cond ((and filename (file-exists? filename))
+ (rdms:warn 'create-database "file exists:" filename)))
+ (let* ((lldb (make-base filename 1 (itypes catalog:init-cols)))
+ (cattab (and lldb (base:open-table lldb base:catalog-id 1
+ (itypes catalog:init-cols)))))
+ (cond
+ ((not lldb) (rdms:error 'make-base "failed.") #f)
+ ((not cattab) (rdms:error 'make-base "catalog missing.")
+ (close-base lldb)
+ #f)
+ (else
+ (let ((desdes-id (base:make-table lldb 1 (itypes columns:init-cols)))
+ (domdes-id (base:make-table lldb 1 (itypes columns:init-cols)))
+ (catdes-id (base:make-table lldb 1 (itypes columns:init-cols)))
+ (domtab-id (base:make-table lldb 1 (itypes domains:init-cols)))
+ )
+ (cond
+ ((not (and catdes-id domdes-id domtab-id desdes-id))
+ (rdms:error 'create-database "make-table failed.")
+ (close-base lldb)
+ #f)
+ (else
+ (init-tab lldb desdes-id columns:init-cols columns:init-cols)
+ (init-tab lldb domdes-id columns:init-cols domains:init-cols)
+ (init-tab lldb catdes-id columns:init-cols catalog:init-cols)
+ (init-tab lldb domtab-id domains:init-cols domains:init-data)
+ (init-tab
+ lldb base:catalog-id catalog:init-cols
+ `((*catalog-desc* 5 ,rdms:columns-name ,catdes-id #f #f)
+ (*domains-desc* 5 ,rdms:columns-name ,domdes-id #f #f)
+ (,rdms:catalog-name 6 *catalog-desc* ,base:catalog-id #f #f)
+ (,rdms:domains-name 5 *domains-desc* ,domtab-id #f #f)
+ (,rdms:columns-name 5 ,rdms:columns-name ,desdes-id #f #f)))
+ (init-database
+ filename #t lldb cattab
+ (base:open-table lldb domtab-id 1 (itypes domains:init-cols))
+ #f))))))))
+
+ (define (base:catalog->domains lldb base:catalog)
+ (let ((cat:row (cat:get-row base:catalog rdms:domains-name)))
+ (and cat:row
+ (base:open-table lldb
+ (list-ref cat:row (+ -2 catalog:bastab-id-pos))
+ 1 (itypes domains:init-cols)))))
+
+ (define (open-database filename mutable)
+ (let* ((lldb (open-base filename mutable))
+ (base:catalog
+ (and lldb (base:open-table lldb base:catalog-id
+ 1 (itypes catalog:init-cols))))
+ (base:domains
+ (and base:catalog (base:catalog->domains lldb base:catalog))))
+ (cond
+ ((not lldb) #f)
+ ((not base:domains) (close-base lldb) #f)
+ (else (init-database
+ filename mutable lldb base:catalog base:domains #f)))))
+
+ (define (init-database rdms:filename mutable lldb
+ base:catalog base:domains rdms:catalog)
+
+ (define (write-database filename)
+ (write-base lldb filename)
+ (set! rdms:filename filename))
+
+ (define (close-database)
+ (close-base lldb)
+ (set! rdms:filename #f)
+ (set! base:catalog #f)
+ (set! base:domains #f)
+ (set! rdms:catalog #f))
+
+ (define row-ref (lambda (row pos) (list-ref row (+ -2 pos))))
+ (define row-eval (lambda (row pos)
+ (let ((ans (list-ref row (+ -2 pos))))
+ (and ans (slib:eval ans)))))
+
+ (define (open-table table-name writable)
+ (define cat:row (cat:get-row base:catalog table-name))
+ (cond ((and writable (not mutable))
+ (rdms:error "can't open-table for writing:" table-name)))
+ (let ((column-limit (row-ref cat:row catalog:column-limit-pos))
+ (desc-table
+ (base:open-table
+ lldb
+ (row-ref (cat:get-row
+ base:catalog
+ (row-ref cat:row catalog:coltab-name-pos))
+ catalog:bastab-id-pos)
+ 1 (itypes columns:init-cols)))
+ (base-table #f)
+ (base:get #f)
+ (primary-limit 1)
+ (column-name-alist '())
+ (column-foreign-list '())
+ (column-domain-list '())
+ (column-type-list '())
+ (export-alist '())
+ (cirs '())
+ (dirs '())
+ (list->key #f)
+ (key->list #f))
+
+ (if (not desc-table)
+ (rdms:error "descriptor table doesn't exist for:" table-name))
+ (do ((ci column-limit (+ -1 ci)))
+ ((zero? ci))
+ (let* ((des:row (des:get-row desc-table ci))
+ (column-name (row-ref des:row columns:name-pos))
+ (column-domain (row-ref des:row columns:domain-name-pos)))
+ (set! cirs
+ (cons (row-eval des:row columns:integrity-rule-pos) cirs))
+ (set! column-name-alist
+ (cons (cons column-name ci) column-name-alist))
+ (cond
+ (column-domain
+ (let ((dom:row (dom:get-row base:domains column-domain)))
+ (set! dirs
+ (cons (row-eval dom:row domains:integrity-rule-pos)
+ dirs))
+ (set! column-type-list
+ (cons (row-ref dom:row domains:type-id-pos)
+ column-type-list))
+ (set! column-domain-list
+ (cons column-domain column-domain-list))
+ (set! column-foreign-list
+ (cons
+ (let ((foreign-name
+ (row-ref dom:row domains:foreign-pos)))
+ (cond
+ ((or (not foreign-name)
+ (eq? foreign-name table-name)) #f)
+ (else
+ (let* ((tab (open-table foreign-name #f))
+ (p? (and tab (tab 'get 1))))
+ (cond
+ ((not tab)
+ (rdms:error "foreign key table missing for:"
+ foreign-name))
+ ((not (= (tab 'primary-limit) 1))
+ (rdms:error "foreign key table wrong type:"
+ foreign-name))
+ (else p?))))))
+ column-foreign-list))))
+ (else
+ (rdms:error "missing domain for column:" ci column-name)))
+ (cond
+ ((row-ref des:row columns:primary?-pos)
+ (set! primary-limit (max primary-limit ci))
+ (cond
+ ((base:supported-key-type? (car column-type-list)))
+ (else (rdms:error "key type not supported by base tables:"
+ (car column-type-list)))))
+ ((base:supported-type? (car column-type-list)))
+ (else (rdms:error "type not supported by base tables:"
+ (car column-type-list))))))
+ (set! base-table
+ (base:open-table lldb (row-ref cat:row catalog:bastab-id-pos)
+ primary-limit column-type-list))
+ (set! base:get ((basic 'make-getter) primary-limit column-type-list))
+ (set! list->key
+ ((basic 'make-list-keyifier) primary-limit column-type-list))
+ (set! key->list
+ ((basic 'make-key->list) primary-limit column-type-list))
+ (let ((export-method
+ (lambda (name proc)
+ (set! export-alist
+ (cons (cons name proc) export-alist))))
+ (generalize-to-table
+ (lambda (operation)
+ (lambda ()
+ (base:for-each-primary-key base-table operation))))
+ (accumulate-over-table
+ (lambda (operation)
+ (lambda () (base:map-primary-key base-table operation))))
+ (ckey:retrieve ;ckey gets whole row (assumes exists)
+ (if (= primary-limit column-limit) key->list
+ (lambda (ckey) (append (key->list ckey)
+ (base:get base-table ckey))))))
+ (export-method
+ 'row:retrieve
+ (if (= primary-limit column-limit)
+ (lambda keys
+ (let ((ckey (list->key keys)))
+ (and (present? base-table ckey) keys)))
+ (lambda keys
+ (let ((vals (base:get base-table (list->key keys))))
+ (and vals (append keys vals))))))
+ (export-method 'row:retrieve*
+ (accumulate-over-table
+ (if (= primary-limit column-limit) key->list
+ ckey:retrieve)))
+ (export-method
+ 'for-each-row
+ (let ((r (if (= primary-limit column-limit) key->list
+ ckey:retrieve)))
+ (lambda (proc) (base:ordered-for-each-key
+ base-table (lambda (ckey) (proc (r ckey)))))))
+ (cond
+ ((and mutable writable)
+ (letrec
+ ((combine-primary-keys
+ (cond
+ ((and (= primary-limit column-limit)
+ (> primary-limit 0))
+ list->key)
+ ((eq? list->key car) list->key)
+ (else
+ (case primary-limit
+ ((1) (let ((keyify-1 ((base 'make-keyifier-1)
+ (car column-type-list))))
+ (lambda (row) (keyify-1 (car row)))))
+ ((2) (lambda (row)
+ (list->key (list (car row) (cadr row)))))
+ ((3) (lambda (row)
+ (list->key (list (car row) (cadr row)
+ (caddr row)))))
+ ((4) (lambda (row)
+ (list->key
+ (list (car row) (cadr row)
+ (caddr row) (cadddr row)))))
+ (else (rdms:error 'combine-primary-keys
+ "bad number of primary keys"
+ primary-limit))))))
+ (uir (row-eval cat:row catalog:integrity-rule-pos))
+ (check-rules
+ (lambda (row)
+ (if (= column-limit (length row)) #t
+ (rdms:error "bad row length:" row))
+ (for-each
+ (lambda (cir dir value column-name column-domain
+ foreign)
+ (cond
+ ((and dir (not (dir value)))
+ (rdms:error "violated domain integrity rule:"
+ table-name column-name
+ column-domain value))
+ ((and cir (not (cir value)))
+ (rdms:error "violated column integrity rule:"
+ table-name column-name value))
+ ((and foreign (not (foreign value)))
+ (rdms:error "foreign key missing:"
+ table-name column-name value))))
+ cirs dirs row column-name-alist column-domain-list
+ column-foreign-list)
+ (cond ((and uir (not (uir row)))
+ (rdms:error "violated user integrity rule:"
+ row)))))
+ (putter
+ ((basic 'make-putter) primary-limit column-type-list))
+ (row:insert
+ (lambda (row)
+ (check-rules row)
+ (let ((ckey (combine-primary-keys row)))
+ (if (present? base-table ckey)
+ (rdms:error 'row:insert "row present:" row))
+ (putter base-table ckey
+ (list-tail row primary-limit)))))
+ (row:update
+ (lambda (row)
+ (check-rules row)
+ (putter base-table (combine-primary-keys row)
+ (list-tail row primary-limit)))))
+
+ (export-method 'row:insert row:insert)
+ (export-method 'row:insert*
+ (lambda (rows) (for-each row:insert rows)))
+ (export-method 'row:update row:update)
+ (export-method 'row:update*
+ (lambda (rows) (for-each row:update rows))))
+
+ (letrec ((base:delete (basic 'delete))
+ (ckey:remove (lambda (ckey)
+ (let ((r (ckey:retrieve ckey)))
+ (and r (base:delete base-table ckey))
+ r))))
+ (export-method 'row:remove
+ (lambda keys
+ (let ((ckey (list->key keys)))
+ (and (present? base-table ckey)
+ (ckey:remove ckey)))))
+ (export-method 'row:delete
+ (lambda keys
+ (base:delete base-table (list->key keys))))
+ (export-method 'row:remove*
+ (accumulate-over-table ckey:remove))
+ (export-method 'row:delete*
+ (generalize-to-table
+ (lambda (ckey) (base:delete base-table ckey))))
+ (export-method 'close-table
+ (lambda () (set! base-table #f)
+ (set! desc-table #f)
+ (set! export-alist #f))))))
+
+ (export-method 'column-names (map car column-name-alist))
+ (export-method 'column-foreigns column-foreign-list)
+ (export-method 'column-domains column-domain-list)
+ (export-method 'column-types column-type-list)
+ (export-method 'primary-limit primary-limit)
+
+ (let ((translate-column
+ (lambda (column)
+ ;;(print 'translate-column column column-name-alist)
+ (let ((colp (assq column column-name-alist)))
+ (cond (colp (cdr colp))
+ ((and (number? column)
+ (integer? column)
+ (<= 1 column column-limit))
+ column)
+ (else (rdms:error "column not in table:"
+ column table-name)))))))
+ (lambda args
+ (cond
+ ((null? args) #f)
+ ((null? (cdr args))
+ (let ((pp (assq (car args) export-alist)))
+ (and pp (cdr pp))))
+ ((not (null? (cddr args)))
+ (rdms:error "too many arguments to methods:" args))
+ (else
+ (let ((ci (translate-column (cadr args))))
+ (cond
+ ((<= ci primary-limit) ;primary-key?
+ (let ((key-extractor
+ ((base 'make-key-extractor)
+ primary-limit column-type-list ci)))
+ (case (car args)
+ ((get) (lambda keys
+ (and (present? base-table (list->key keys))
+ (list-ref keys (+ -1 ci)))))
+ ((get*) (lambda ()
+ (base:map-primary-key
+ base-table
+ (lambda (ckey) (key-extractor ckey)))))
+ (else #f))))
+ (else
+ (let ((index (- ci (+ 1 primary-limit))))
+ (case (car args)
+ ((get) (lambda keys
+ (let ((row (base:get base-table
+ (list->key keys))))
+ (and row (list-ref row index)))))
+ ((get*) (lambda ()
+ (base:map-primary-key
+ base-table
+ (lambda (ckey)
+ (list-ref (base:get base-table ckey)
+ index)))))
+ (else #f)))))))))))))
+
+ (define create-table
+ (and
+ mutable
+ (lambda (table-name . desc)
+ (if (not rdms:catalog)
+ (set! rdms:catalog (open-table rdms:catalog-name #t)) #f)
+ (cond
+ ((table-exists? table-name)
+ (rdms:error "table already exists:" table-name) #f)
+ ((null? desc)
+ (let ((colt-id
+ (base:make-table lldb 1 (itypes columns:init-cols))))
+ ((rdms:catalog 'row:insert)
+ (list table-name
+ (length columns:init-cols)
+ ((rdms:catalog 'get 'coltab-name)
+ rdms:columns-name)
+ colt-id
+ #f
+ #f)))
+ (open-table table-name #t))
+ ((null? (cdr desc))
+ (set! desc (car desc))
+ (let ((colt-id ((rdms:catalog 'get 'bastab-id) desc)))
+ (cond
+ (colt-id
+ (let ((coltable (open-table desc #f))
+ (types '())
+ (prilimit 0)
+ (colimit 0)
+ (colerr #f))
+ (for-each (lambda (n p d)
+ (if (number? n) (set! colimit (max colimit n))
+ (set! colerr #t))
+ (if p (set! prilimit (+ 1 prilimit)) #f)
+ (set! types
+ (cons (dom:get-row base:domains d)
+ types)))
+ ((coltable 'get* 'column-number))
+ ((coltable 'get* 'primary-key?))
+ ((coltable 'get* 'domain-name)))
+ (cond (colerr (rdms:error "some column lacks a number.") #f)
+ ((or (< prilimit 1)
+ (and (> prilimit 4)
+ (not (= prilimit colimit))))
+ (rdms:error "unreasonable number of primary keys:"
+ prilimit))
+ (else
+ ((rdms:catalog 'row:insert)
+ (list table-name colimit desc
+ (base:make-table lldb prilimit types) #f #f))
+ (open-table table-name #t)))))
+ (else
+ (rdms:error "table descriptor not found for:" desc) #f))))
+ (else (rdms:error 'create-table "too many args:"
+ (cons table-name desc))
+ #f)))))
+
+ (define (table-exists? table-name)
+ (present? base:catalog (cat:keyify-1 table-name)))
+
+ (define delete-table
+ (and mutable
+ (lambda (table-name)
+ (if (not rdms:catalog)
+ (set! rdms:catalog (open-table rdms:catalog-name #t)) #f)
+ (let ((table (open-table table-name #t))
+ (row ((rdms:catalog 'row:remove) table-name)))
+ (and row (base:kill-table
+ lldb
+ (list-ref row (+ -1 catalog:bastab-id-pos))
+ (table 'primary-limit)
+ (table 'column-type-list))
+ row)))))
+
+ (lambda (operation-name)
+ (case operation-name
+ ((close-database) close-database)
+ ((write-database) write-database)
+ ((open-table) open-table)
+ ((delete-table) delete-table)
+ ((create-table) create-table)
+ ((table-exists?) table-exists?)
+ (else #f)))
+ )
+ (lambda (operation-name)
+ (case operation-name
+ ((create-database) create-database)
+ ((open-database) open-database)
+ (else #f)))
+ ))