From 87b82b5822ca54228cfa6df29be3ad9d4bc47d16 Mon Sep 17 00:00:00 2001
From: Bryan Newbold <bnewbold@robocracy.org>
Date: Mon, 20 Feb 2017 00:05:28 -0800
Subject: Import Upstream version 2d2

---
 dbutil.scm | 74 +++++++++++++++++++++++++++++++++++++++++++++++++-------------
 1 file changed, 59 insertions(+), 15 deletions(-)

(limited to 'dbutil.scm')

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)
-- 
cgit v1.2.3