home *** CD-ROM | disk | FTP | other *** search
/ HAKERIS 11 / HAKERIS 11.ISO / linux / system / LinuxConsole 0.4 / linuxconsole0.4install-en.iso / guile0.4.lcm / share / guile / slib / dbrowse.scm < prev    next >
Encoding:
Text File  |  2004-01-06  |  3.1 KB  |  93 lines
  1. ;;; "dbrowse.scm" relational-database-browser
  2. ; Copyright 1996, 1997, 1998 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 'database-utilities)
  21. (require 'printf)
  22.  
  23. (define browse:db #f)
  24.  
  25. (define (browse . args)
  26.   (define table-name #f)
  27.   (cond ((null? args))
  28.     ((procedure? (car args))
  29.      (set! browse:db (car args))
  30.      (set! args (cdr args)))
  31.     ((string? (car args))
  32.      (set! browse:db (open-database (car args)))
  33.      (set! args (cdr args))))
  34.   (cond ((null? args))
  35.     (else (set! table-name (car args))))
  36.   (let* ((open-table (browse:db 'open-table))
  37.      (catalog (and open-table (open-table '*catalog-data* #f))))
  38.     (cond ((not catalog)
  39.        (slib:error 'browse "could not open catalog"))
  40.       ((not table-name)
  41.        (browse:display-dir '*catalog-data* catalog))
  42.       (else
  43.        (let ((table (open-table table-name #f)))
  44.          (cond (table (browse:display-table table-name table)
  45.               (table 'close-table))
  46.            (else (slib:error 'browse "could not open table"
  47.                      table-name))))))))
  48.  
  49. (define (browse:display-dir table-name table)
  50.   (printf "%s Tables:\\n" table-name)
  51.   ((table 'for-each-row)
  52.    (lambda (row) (printf "\\t%s\\n" (car row)))))
  53.  
  54. (define (browse:display-table table-name table)
  55.   (let* ((width 18)
  56.      (dw (string-append "%-" (number->string width)))
  57.      (dwp (string-append "%-" (number->string width) "."
  58.                  (number->string (+ -1 width))))
  59.      (dwp-string (string-append dwp "s"))
  60.      (dwp-any (string-append dwp "a"))
  61.      (dw-integer (string-append dw "d"))
  62.      (underline (string-append (make-string (+ -1 width) #\=) " "))
  63.      (form ""))
  64.     (printf "Table: %s\\n" table-name)
  65.     (for-each (lambda (name) (printf dwp-string name))
  66.           (table 'column-names))
  67.     (newline)
  68.     (for-each (lambda (foreign) (printf dwp-any foreign))
  69.           (table 'column-foreigns))
  70.     (newline)
  71.     (for-each (lambda (domain) (printf dwp-string domain))
  72.           (table 'column-domains))
  73.     (newline)
  74.     (for-each (lambda (type)
  75.         (case type
  76.           ((integer number uint base-id)
  77.            (set! form (string-append form dw-integer)))
  78.           ((boolean domain expression atom)
  79.            (set! form (string-append form dwp-any)))
  80.           ((string symbol)
  81.            (set! form (string-append form dwp-string)))
  82.           (else (slib:error 'browse:display-table "unknown type" type)))
  83.         (printf dwp-string type))
  84.           (table 'column-types))
  85.     (newline)
  86.     (set! form (string-append form "\\n"))
  87.     (for-each (lambda (domain) (printf underline))
  88.           (table 'column-domains))
  89.     (newline)
  90.     ((table 'for-each-row)
  91.      (lambda (row)
  92.        (apply printf form row)))))
  93.