summaryrefslogtreecommitdiffstats
path: root/dbutil.scm
diff options
context:
space:
mode:
authorJames LewisMoss <dres@debian.org>2001-07-27 23:45:29 -0400
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:29 -0800
commitf559c149c83da84d0b1c285f0298c84aec564af9 (patch)
treef1c91bcb9bb5e6dad87b643127c3f878d80d89ee /dbutil.scm
parentc394920caedf3dac1981bb6b10eeb47fd6e4bb21 (diff)
parent87b82b5822ca54228cfa6df29be3ad9d4bc47d16 (diff)
downloadslib-f559c149c83da84d0b1c285f0298c84aec564af9.tar.gz
slib-f559c149c83da84d0b1c285f0298c84aec564af9.zip
Import Debian changes 2d2-1debian/2d2-1
slib (2d2-1) unstable; urgency=low * New upstream version * Revert back to free. Is now so. slib (2d1-1) unstable; urgency=low * New upstream version. * Move to non-free. FSF pointed out license doesn't allow modified versions to be distributed. * Get a complete list of copyrights that apply to the source into copyright file. * Remove setup for guile 1.3. * Remove postrm. Just calling install-info (lintian) Move install-info call to prerm since doc-base doesn't do install-info. slib (2c9-3) unstable; urgency=low * Change info location to section "The Algorithmic Language Scheme" to match up with where guile puts it's files. * Postinst is running slibconfig now. (Closes: #75891) slib (2c9-2) unstable; urgency=low * Stop installing slibconfig (for guile). * In postinst if /usr/sbin/slibconnfig exists call it (Close: #75843 #75891). slib (2c9-1) unstable; urgency=low * New upstream (Closes: #74760) * replace string-index with strsrch:string-index in http-cgi.scm. * Add doc-base support (Closes: #31163)
Diffstat (limited to 'dbutil.scm')
-rw-r--r--dbutil.scm74
1 files changed, 59 insertions, 15 deletions
diff --git a/dbutil.scm b/dbutil.scm
index 1ed84da..248ec1d 100644
--- a/dbutil.scm
+++ b/dbutil.scm
@@ -1,9 +1,9 @@
;;; "dbutil.scm" relational-database-utilities
-; Copyright 1994, 1995, 1997 Aubrey Jaffer
+; Copyright 1994, 1995, 1997, 2000, 2001 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.
+;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.
@@ -50,6 +50,18 @@
(((make-relational-system (slib:eval type)) 'open-database)
path #f))))
+(define (dbutil: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 (dbutil:create-database path type)
(require type)
(let ((rdb (((make-relational-system (slib:eval type)) 'create-database)
@@ -147,17 +159,7 @@
((domain-checker
no-parameters
no-parameter-names
- (lambda (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)))))
+ dbutil:check-domain
"return procedure to check given domain name")
(add-domain
@@ -179,12 +181,40 @@
((tab 'row:update) row))
(dbutil:wrap-command-interface rdb)))
+(define (make-defaulter arity type)
+ `(lambda (pl)
+ ',(case arity
+ ((optional nary) '())
+ ((boolean) #f)
+ ((single nary1)
+ (case type
+ ((string) '(""))
+ ((symbol) '(nil))
+ ((number) '(0))
+ (else '(#f))))
+ (else (slib:error 'make-defaulter 'unknown 'arity arity)))))
+
+(define (get-foreign-choices tab)
+ (define dlst ((tab 'get* 1)))
+ (do ((dlst dlst (cdr dlst))
+ (vlst (if (memq 'visible-name (tab 'column-names))
+ ((tab 'get* 'visible-name))
+ dlst)
+ (cdr vlst))
+ (out '() (if (member (car dlst) (cdr dlst))
+ out
+ (cons (list (car dlst) (car vlst)) out))))
+ ((null? dlst) out)))
+
(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))
@@ -264,7 +294,21 @@
((tab 'close-table))))))
(for-each (lambda (spec) (apply define-table spec)) spec-list))
+(define (dbutil:list-table-definition rdb table-name)
+ (cond (((rdb 'table-exists?) table-name)
+ (let* ((table ((rdb 'open-table) table-name #f))
+ (prilimit (table 'primary-limit))
+ (coldefs (map list
+ (table 'column-names)
+ (table 'column-domains))))
+ (list table-name
+ (butnthcdr prilimit coldefs)
+ (nthcdr prilimit coldefs)
+ ((table 'row:retrieve*)))))
+ (else #f)))
+
(define create-database dbutil:create-database)
(define open-database! dbutil:open-database!)
(define open-database dbutil:open-database)
(define define-tables dbutil:define-tables)
+(define list-table-definition dbutil:list-table-definition)