home *** CD-ROM | disk | FTP | other *** search
/ Dream 44 / Amiga_Dream_44.iso / RiscPc / programmation / scm4e2.arc / !Scm / slib / dbutil < prev    next >
Text File  |  1994-12-18  |  2KB  |  67 lines
  1. ;;; "dbutil.scm" relational-database-utilities
  2. ; Copyright 1994 Aubrey Jaffer
  3. ;
  4. ;Permission to copy this software, to redistribute it, and to use it
  5. ;for any purpose is granted, subject to the following restrictions and
  6. ;understandings.
  7. ;
  8. ;1.  Any copy made of this software must include this copyright notice
  9. ;in full.
  10. ;
  11. ;2.  I have made no warrantee or representation that the operation of
  12. ;this software will be error-free, and I am under no obligation to
  13. ;provide any services, by way of maintenance, update, or otherwise.
  14. ;
  15. ;3.  In conjunction with products arising from the use of this
  16. ;material, there shall be no use of my name in any advertising,
  17. ;promotional, or sales literature without prior written consent in
  18. ;each case.
  19.  
  20. (require 'relational-database)
  21.  
  22. (define (dbutil:define-tables rdb spec-list)
  23.   (define new-tables '())
  24.   (define (define-table name prikeys slots data)
  25.     (define create-table (rdb 'create-table))
  26.     (define descname
  27.       (string->symbol (string-append "desc:" (symbol->string name))))
  28.     (let* ((tab (create-table descname))
  29.        (row:insert (tab 'row:insert))
  30.        (domains ((rdb 'open-table) '*domains-data* #f))
  31.        (dom:typ (domains 'get 4))
  32.        (j 0))
  33.       (define (check-domain dname)
  34.     (cond ((dom:typ dname))
  35.           ((member dname new-tables)
  36.            (let* ((ftab ((rdb 'open-table)
  37.                  (string->symbol
  38.                   (string-append "desc:" (symbol->string dname)))
  39.                  #f)))
  40.          ((rdb 'add-domain)
  41.           (list dname dname #f
  42.             (dom:typ ((ftab 'get 'domain-name) 1)) #f))))))
  43.  
  44.       (set! new-tables (cons name new-tables))
  45.       (for-each (lambda (des)
  46.           (set! j (+ 1 j))
  47.           (check-domain (cadr des))
  48.           (row:insert (list j #t (car des)
  49.                     (if (null? (cddr des)) #f (caddr des))
  50.                     (cadr des))))
  51.         prikeys)
  52.       (for-each (lambda (des)
  53.           (set! j (+ 1 j))
  54.           (check-domain (cadr des))
  55.           (row:insert (list j #f (car des)
  56.                     (if (null? (cddr des)) #f (caddr des))
  57.                     (cadr des))))
  58.         slots)
  59.       ((tab 'close-table))
  60.       (set! tab (create-table name descname))
  61.       (set! row:insert (tab 'row:insert))
  62.       (for-each row:insert data)
  63.       ((tab 'close-table))))
  64.   (for-each (lambda (spec) (apply define-table spec)) spec-list))
  65.  
  66. (define define-tables dbutil:define-tables)
  67.