1
;;; postgres-meta.scm --- Methods for understanding PostgreSQL data structures
3
;; Guile-pg - A Guile interface to PostgreSQL
4
;; Copyright (C) 2002, 2003 Free Software Foundation, Inc.
6
;; This program is free software; you can redistribute it and/or modify
7
;; it under the terms of the GNU General Public License as published by
8
;; the Free Software Foundation; either version 2 of the License, or
9
;; (at your option) any later version.
11
;; This program is distributed in the hope that it will be useful,
12
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14
;; GNU General Public License for more details.
16
;; You should have received a copy of the GNU General Public License
17
;; along with this program; if not, write to the Free Software
18
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
20
;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
24
;; This module exports the procs:
25
;; (infer-defs CONN TABLE-NAME) => defs
26
;; (describe-table! DB-NAME TABLE-NAME)
30
(define-module (database postgres-meta)
31
:use-module (database postgres)
32
:use-module (database postgres-types)
33
:use-module (database postgres-resx)
34
:use-module (database postgres-table)
35
:use-module (srfi srfi-13)
39
(define (make-M:pg-class db-name)
40
(pgtable-manager db-name "pg_class"
53
(reltriggers smallint)
61
(define (table-info M:pg-class name)
63
(string-join (map (lambda (field)
64
(let ((s (symbol->string field)))
65
(simple-format #f "rel~A as ~A" s s)))
74
(string-append "where relname='" name "'")))
76
(define (table-fields-info conn table-name)
77
(pg-exec conn (string-append
78
" SELECT a.attname, t.typname, a.attlen, a.atttypmod,"
79
" a.attnotnull, a.atthasdef, a.attnum"
80
" FROM pg_class c, pg_attribute a, pg_type t"
81
" WHERE c.relname = '" table-name "'"
83
" AND a.attrelid = c.oid"
84
" AND a.atttypid = t.oid"
85
" ORDER BY a.attnum")))
87
;; Return a @dfn{defs} form suitable for use with @code{pgtable-manager} for
88
;; connection @var{conn} and @var{table-name}. The column names are exact.
89
;; The column types are incorrect for array types, which are described as
90
;; @code{_FOO}; there is currently no way to infer whether this means
91
;; @code{FOO[]} or @code{FOO[][]}, etc, without looking at the table's data.
92
;; No type options are checked at this time.
94
(define (infer-defs conn table-name)
95
(let ((res (table-fields-info conn table-name)))
96
(map (lambda args args)
97
(result-field->object-list res 0 string->symbol)
98
(result-field->object-list res 1 string->symbol))))
100
;; Display information on database @var{db-name} table @var{table-name}.
101
;; Include a defs form suitable for use with @code{pgtable-manager};
102
;; info about the table (kind, natts, hasindex, checks, triggers, hasrules);
103
;; and info about each field in the table (typname, attlen, atttypmod,
104
;; attnotnull, atthasdef, attnum).
106
(define (describe-table! db-name table-name)
107
(let ((M:pg-class (make-M:pg-class db-name)))
108
(for-each write-line (infer-defs (M:pg-class 'pgdb) table-name))
109
(for-each (lambda (x) (display-table
110
(cond ((pg-result? x)
111
(tuples-result->table x))
113
`(,(table-info M:pg-class table-name)
114
,(table-fields-info (M:pg-class 'pgdb) table-name)))))
116
;; --------------------------------------------------------------------------
117
;; this belongs elsewhere
119
(define (display-table table . style)
121
(define (styler name)
123
((space) (lambda (x) (case x ((h) #\space) (else " "))))
124
((h-only) (lambda (x) (case x ((h) #\-) ((v) " ") ((+) "-"))))
125
((v-only) (lambda (x) (case x ((h) #\space) ((v) "|") ((+) "|"))))
126
((+-only) (lambda (x) (case x ((h) #\space) ((v) " ") ((+) "+"))))
127
((no-h) (lambda (x) (case x ((h) #\space) ((v) "|") ((+) "+"))))
128
((no-v) (lambda (x) (case x ((h) #\-) ((v) " ") ((+) "+"))))
129
((no-+) (lambda (x) (case x ((h) #\-) ((v) "|") ((+) " "))))
130
((fat-space) (lambda (x) (case x ((h) #\space) (else " "))))
131
((fat-no-v) (lambda (x) (case x ((h) #\-) ((v) " ") ((+) "-+-"))))
132
((fat-h-only) (lambda (x) (case x ((h) #\-) ((v) " ") ((+) "--"))))
133
(else (error "bad style:" style))))
135
(let* ((style (if (null? style)
136
(lambda (x) (case x ((h) #\-) ((v) "|") ((+) "+")))
137
(let ((style (car style)))
138
(cond ((procedure? style) style)
139
((symbol? style) (styler style))
140
(else (error "bad style:" style))))))
141
(names (object-property table 'names))
142
(widths (object-property table 'widths))
143
(tuples (iota (car (array-dimensions table))))
144
(fields (iota (cadr (array-dimensions table)))))
146
(define (-row sep producer padding)
147
(for-each (lambda (fn)
149
(let ((s (producer fn)))
151
(display (make-string (- (array-ref widths fn)
158
(define (-hr) (-row (style '+) (lambda (fn) "") (style 'h)))
162
(-row (style 'v) (lambda (fn) (array-ref names fn)) #\space)
164
(for-each (lambda (tn)
166
(lambda (fn) (array-ref table tn fn))
171
;;; postgres-meta.scm ends here
added
removed
scm/postgres-meta.scm
