Changeset 14753 in project


Ignore:
Timestamp:
05/23/09 16:27:03 (11 years ago)
Author:
sjamaan
Message:

Add high-level interface and type parsing/unparsing, completing most of the code

Location:
release/4/postgresql/trunk
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • release/4/postgresql/trunk/postgresql.scm

    r14749 r14753  
    2020
    2121(module postgresql
    22  (connect reset-connection disconnect connection?
     22 (update-type-parsers! default-type-parsers
     23  char-parser bool-parser bytea-parser numeric-parser
     24  update-type-unparsers! default-type-unparsers
     25  connect reset-connection disconnect connection?
    2326  exec-simple-queries exec-query
    24   result? result-rows result-columns result-column-name result-column-index
    25   result-table-oid result-table-column-index result-column-format
    26   result-column-type result-column-type-modifier result-value
    27   result-affected-rows result-inserted-oid
    28   invalid-oid escape-string escape-bytea unescape-bytea
    29 
    30   query-fold-left query-for-each query-tuples named-tuples)
     27  result? clear-result! result-row-count result-column-count
     28  result-column-index result-column result-column-format
     29  result-column-type result-column-type-modifier result-columns
     30  result-table-oid result-table-column-index
     31  result-value result-values result-alist result-affected-rows
     32  result-inserted-oid invalid-oid escape-string escape-bytea unescape-bytea
     33  query-fold query-fold* query-for-each query-for-each*)
    3134
    3235(import chicken scheme foreign)
    3336
    34 (require-extension lolevel data-structures extras
    35                    srfi-1 srfi-4 srfi-13 srfi-18 srfi-69 sql-null)
     37(require-extension srfi-1 srfi-4 srfi-13 srfi-18 srfi-69
     38                   extras data-structures sql-null)
    3639
    3740(foreign-declare "#include <libpq-fe.h>")
     
    9093(define PQftype (foreign-lambda oid PQftype (const pgresult*) int))
    9194(define PQfmod (foreign-lambda int PQfmod (const pgresult*) int))
    92 (define PQgetvalue (foreign-lambda (c-pointer char) PQgetvalue (const pgresult*) int int))
    9395(define PQgetisnull (foreign-lambda bool PQgetisnull (const pgresult*) int int))
    9496(define PQcmdTuples (foreign-lambda nonnull-c-string PQcmdTuples pgresult*))
     
    136138
    137139;;;;;;;;;;;;;;;;;;;;;;;;
    138 ;;;;;; Connections
     140;;;; Type parsers
    139141;;;;;;;;;;;;;;;;;;;;;;;;
    140142
    141 (define-record pg-connection ptr)
     143(define (char-parser str) (string-ref str 0))
     144
     145(define (bool-parser str) (string=? str "t"))
     146
     147(define (abstime-parser str) str)
     148
     149(define (reltime-parser str) str)
     150
     151(define (parse-format-string s)
     152  (let-syntax ((push! (syntax-rules ()
     153                        ((_ value place)
     154                         (set! place (cons value place))))))
     155    (do ([i 0 (+ i 1)]
     156         [ranges (list)]
     157         [cur-range (list)]
     158         [len (string-length s)])
     159        ([= i len]
     160         (when (not (null? cur-range))
     161           (push! (cons (- i (length cur-range)) i)
     162                  ranges))
     163         (reverse! ranges))
     164      (let ([char (string-ref s i)])
     165        (cond ([and (or (null? cur-range)
     166                        (char=? char (car cur-range)))
     167                    (char-alphabetic? char)]
     168               (push! char cur-range))
     169              ([and (not (null? cur-range))
     170                    (not (char=? char (car cur-range)))]
     171               (push! (cons (- i (length cur-range)) i)
     172                      ranges)
     173               (set! cur-range
     174                     (if (char-alphabetic? char)
     175                         (list char)
     176                         (list)))))))))
     177
     178(define-syntax define-time-parser
     179  (syntax-rules ()
     180    ((_ name format-string)
     181     (define name
     182       (let ((format-ranges (parse-format-string format-string)))
     183         (lambda (str)
     184           (apply
     185            vector
     186            (map (lambda (range)
     187                   (if (> (cdr range) (string-length str))
     188                       0
     189                       (string->number
     190                        (substring str (car range) (cdr range)))))
     191                 format-ranges))))))))
     192
     193(define-time-parser date-parser "YYYY-MM-DD")
     194(define-time-parser timestamp-parser "YYYY-MM-DD hh:mm:ss.ssssss")
     195(define-time-parser timestamp/tz-parser "YYYY-MM-DD hh:mm:ss.sssssszzz")
     196(define-time-parser time-parser "hh:mm:ss.ssssss")
     197
     198(define (numeric-parser str)
     199  (or (string->number str)
     200      (postgresql-error 'numeric-parser "Unable to parse number" str)))
     201
     202(define (bytea-parser str)
     203  (blob->u8vector/shared (string->blob (unescape-bytea str))))
     204
     205(define default-type-parsers
     206  (make-parameter
     207   `(("text" . ,identity)
     208     ("bytea" . ,bytea-parser)
     209     ("char" . ,char-parser)
     210     ("bpchar" . ,identity)
     211     ("bool" . ,bool-parser)
     212     ("int8" . ,numeric-parser)
     213     ("int4" . ,numeric-parser)
     214     ("int2" . ,numeric-parser)
     215     ("float4" . ,numeric-parser)
     216     ("float8" . ,numeric-parser)
     217     ("abstime" . ,abstime-parser)
     218     ("reltime" . ,reltime-parser)
     219     ("date" . ,date-parser)
     220     ("time" . ,time-parser)
     221     ("timestamp" . ,timestamp-parser)
     222     ("timestamptz" . ,timestamp/tz-parser)
     223     ("numeric" . ,numeric-parser)
     224     ("oid" . ,numeric-parser))))
     225
     226;;;;;;;;;;;;;;;;;;;;;;;
     227;;;; Type unparsers
     228;;;;;;;;;;;;;;;;;;;;;;;
     229
     230(define (bool-unparser b)
     231  (if b "TRUE" "FALSE"))
     232
     233(define default-type-unparsers
     234  (make-parameter
     235   `((,string? . ,identity)
     236     (,u8vector? . ,u8vector->blob/shared)
     237     (,char? . ,string)
     238     (,boolean? . ,bool-unparser)
     239     (,number? . ,number->string)
     240     #;(,vector? . ,vector-unparser))))
     241
     242;; Retrieve type-oids from PostgreSQL:
     243(define (update-type-parsers! conn #!optional new-type-parsers)
     244  (let ((type-parsers (or new-type-parsers (pg-connection-type-parsers conn)))
     245        (ht (make-hash-table))
     246        (result '()))
     247    ;; Set the parsers now, so that we will be retrieving raw data
     248    (pg-connection-oid-parsers-set! conn ht)
     249    (pg-connection-type-parsers-set! conn type-parsers)
     250    (unless (null? type-parsers)   ; empty IN () clause is not allowed
     251      (query-for-each*
     252       (lambda (oid typname)
     253         (and-let* ((procedure (assoc typname type-parsers)))
     254           (hash-table-set! ht (string->number oid) (cdr procedure))))
     255       conn
     256       (conc "SELECT oid, typname FROM pg_type WHERE typname IN "
     257             "('" (string-intersperse
     258                   (map (lambda (p) (escape-string conn (car p)))
     259                        type-parsers) "', '") "')")))))
     260
     261(define (update-type-unparsers! conn new-type-unparsers)
     262  (pg-connection-type-unparsers-set! conn new-type-unparsers))
     263
     264;;;;;;;;;;;;;;;;;;;;;;;;
     265;;;; Connections
     266;;;;;;;;;;;;;;;;;;;;;;;;
     267
     268(define-record pg-connection ptr type-parsers oid-parsers type-unparsers)
    142269(define connection? pg-connection?)
    143270
     
    174301        alist)))
    175302
    176 (define (connect connection-spec)
     303(define (connect connection-spec
     304                 #!optional
     305                 (type-parsers (default-type-parsers))
     306                 (type-unparsers (default-type-unparsers)))
    177307  (let* ((connection-spec (if (string? connection-spec)
    178308                              connection-spec
     
    192322                          connection-spec)))
    193323     (else
    194       (let ((conn (make-pg-connection conn-ptr)))
     324      (let ((conn (make-pg-connection conn-ptr type-parsers
     325                                      (make-hash-table) type-unparsers)))
    195326        ;; We don't want libpq to piss in our stderr stream
    196327        ((foreign-lambda* void ((pgconn* conn))
     
    200331        ;; Retrieve type-information from PostgreSQL metadata for use by
    201332        ;; the various value-parsers.
    202         (fixup-types conn)
     333        (update-type-parsers! conn)
    203334        conn)))))
    204335
    205336(define (reset-connection connection)
    206337  (let ((conn-ptr (pg-connection-ptr connection)))
    207     (if (PQresetStart conn-ptr)
     338    (if (PQresetStart conn-ptr) ;; Update oid-parsers?
    208339        (wait-for-connection! connection PQresetPoll)
    209340        (let ((error-message (PQerrorMessage conn-ptr)))
     
    216347  (and-let* ((conn-ptr (pg-connection-ptr connection)))
    217348    (pg-connection-ptr-set! connection #f)
     349    (pg-connection-type-parsers-set! connection #f)
     350    (pg-connection-oid-parsers-set! connection #f)
    218351    (PQfinish conn-ptr))
    219352  (void))
     
    223356;;;;;;;;;;;;;;;;;;;;;
    224357
    225 (define-record pg-result ptr)
     358(define-record pg-result ptr value-parsers)
    226359(define result? pg-result?)
    227360
    228 (define (clear-result result)
     361(define (clear-result! result)
    229362  (and-let* ((result-ptr (pg-result-ptr result)))
    230363    (pg-result-ptr-set! result #f)
    231364    (PQclear result-ptr)))
    232365
    233 (define (result-rows result)
     366(define (result-row-count result)
    234367  (PQntuples (pg-result-ptr result)))
    235368
    236 (define (result-columns result)
     369(define (result-column-count result)
    237370  (PQnfields (pg-result-ptr result)))
    238371
     
    240373;; out of bounds and nonexistant columns, and signal it.
    241374(define (check-result-column-index! result index location)
    242   (when (>= index (result-columns result))
     375  (when (>= index (result-column-count result))
    243376    (postgresql-error
    244377     location (sprintf "Result column ~A out of bounds" index) result index)))
    245378
    246379(define (check-result-row-index! result index location)
    247   (when (>= index (result-rows result))
     380  (when (>= index (result-row-count result))
    248381    (postgresql-error
    249382     location (sprintf "Result row ~A out of bounds" index) result index)))
    250383
    251 (define (result-column-name result index)
    252   (check-result-column-index! result index 'result-column-name)
     384(define (result-column result index)
     385  (check-result-column-index! result index 'result-column)
    253386  (PQfname (pg-result-ptr result) index))
     387
     388(define (result-columns result)
     389  (let loop ((ptr (pg-result-ptr result))
     390             (row '())
     391             (idx (result-column-count result)))
     392    (if (= idx 0)
     393        row
     394        (loop ptr (cons (PQfname ptr (sub1 idx)) row) (sub1 idx)))))
    254395
    255396(define (result-column-index result name)
     
    270411    (and (> idx 0) (sub1 idx))))
    271412
     413(define format-table
     414  '((0 . text) (1 . binary)))
     415
     416(define (format->symbol format)
     417  (or (alist-ref format format-table eq?)
     418      (postgresql-error 'format->symbol "Unknown format" format)))
     419
     420(define (symbol->format symbol)
     421  (or (and-let* ((res (rassoc symbol format-table eq?)))
     422        (car res))
     423      (postgresql-error 'format->symbol "Unknown format" symbol)))
     424
    272425(define (result-column-format result index)
    273426  (check-result-column-index! result index 'result-column-format)
    274   (let ((type (alist-ref (PQfformat (pg-result-ptr result) index)
    275                          '((0 . text) (1 . binary)))))
    276     (or type
    277         (postgresql-error 'result-column-format
    278                           (conc "Unknown column type " type)
    279                           result index))))
     427  (format->symbol (PQfformat (pg-result-ptr result) index)))
    280428
    281429(define (result-column-type result index)
     
    290438    (and (>= mod 0) mod)))
    291439
    292 (define (result-value result row column)
     440;; Unchecked version, for speed
     441(define (result-value* result row column #!key raw)
     442  (if (PQgetisnull (pg-result-ptr result) row column)
     443      (sql-null)
     444      (let ((value ((foreign-safe-lambda*
     445                     scheme-object ((c-pointer res) (int row) (int col))
     446                     "C_word fin, *str; char *val; int len;"
     447                     "len = PQgetlength(res, row, col);"
     448                     "str = C_alloc(C_bytestowords(len + sizeof(C_header)));"
     449                     "val = PQgetvalue(res, row, col);"
     450                     "fin = C_string(&str, len, val);"
     451                     "if (PQfformat(res, col) == 1) /* binary? */"
     452                     "        C_string_to_bytevector(fin);"
     453                     "C_return(fin);")
     454                    (pg-result-ptr result) row column)))
     455        (if (or raw (blob? value))
     456            value
     457            ((vector-ref (pg-result-value-parsers result) column) value)))))
     458
     459(define (result-value result row column #!key raw)
    293460  (check-result-row-index! result row 'result-value)
    294461  (check-result-column-index! result column 'result-value)
    295   (if (PQgetisnull (pg-result-ptr result) row column)
    296       (sql-null)
    297       ((foreign-safe-lambda*
    298         scheme-object ((c-pointer res) (int row) (int col))
    299         "C_word fin, *str; char *val; int len;"
    300         "len = PQgetlength(res, row, col);"
    301         "str = C_alloc(C_bytestowords(len + sizeof(C_header)));"
    302         "val = PQgetvalue(res, row, col);"
    303         "fin = C_string(&str, len, val);"
    304         "if (PQfformat(res, col) == 1) /* binary? */"
    305         "        C_string_to_bytevector(fin);"
    306         "C_return(fin);")
    307        (pg-result-ptr result) row column)))
     462  (result-value* result row column raw: raw))
     463
     464(define (result-values result row #!key raw)
     465  (check-result-row-index! result row 'result-list)
     466  (let loop ((list '())
     467             (column (result-column-count result)))
     468    (if (= column 0)
     469        list
     470        (loop (cons (result-value* result row (sub1 column) raw: raw) list)
     471              (sub1 column)))))
     472
     473;; (define (result-alist result row)
     474;;   (map cons (result-columns result row) (result-values result row)))
     475(define (result-alist result row)
     476  (check-result-row-index! result row 'result-alist)
     477  (let loop ((alist '())
     478             (column (result-column-count result)))
     479    (if (= column 0)
     480        alist
     481        (loop (cons (cons (PQfname (pg-result-ptr result) column)
     482                          (result-value* result row (sub1 column))) alist)
     483              (sub1 column)))))
    308484
    309485;;; TODO: Do we want/need PQnparams and PQparamtype bindings?
     
    329505                                  (PQerrorMessage conn-ptr))
    330506                            conn-ptr)))))
     507
     508(define (make-value-parsers conn pqresult)
     509  (let ((nfields (PQnfields pqresult)))
     510    (do ([col 0 (+ col 1)]
     511         [parsers (make-vector nfields)])
     512        ([= col nfields] parsers)
     513      (vector-set! parsers col
     514                   (hash-table-ref (pg-connection-oid-parsers conn)
     515                                   (PQftype pqresult col)
     516                                   (lambda () identity))))))
    331517
    332518;; Collect the result pointers from the last query.
     
    379565              (signal condition)))
    380566           (else
    381             (let ((result-obj (make-pg-result result)))
    382               (set-finalizer! result-obj clear-result)
     567            (let ((result-obj (make-pg-result result
     568                                              (make-value-parsers conn result))))
     569              (set-finalizer! result-obj clear-result!)
    383570              (loop (cons result-obj results)))))
    384571          (reverse! results)))))
    385572
    386 
    387 ;; TODO: Ensure that no two queries can be issued at the same time! (thread lock)
    388 ;; This is needed because there's always only one "active" query.
    389573(define (exec-simple-queries conn query)
    390574  (if ((foreign-lambda bool PQsendQuery pgconn* (const c-string))
     
    396580                        conn query)))
    397581
    398 (define (exec-query conn query #!optional (params '()) #!key (format 'text))
    399   (let ((params ;; Check all params and ensure they are proper pairs
    400          (map   ;; See if this can be moved into C
    401           (lambda (p)
    402             (let ((p (if (pair? p) p (cons p 0))))
    403               (when (and (not (string? (car p)))
    404                          (not (blob? (car p)))
    405                          (not (sql-null? (car p))))
    406                 (postgresql-error
    407                  'exec-query (sprintf "Param value is not a string, sql-null or blob: ~S" p)
    408                  conn query params format))
    409               (when (not (integer? (cdr p)))
    410                 (postgresql-error
    411                  'exec-query (sprintf "Param type is not an oid: ~S" p)
    412                  conn query params format))
    413               (if (sql-null? (car p)) (cons #f (cdr p)) p))) params))
    414         (send-query
    415          (foreign-lambda*
    416           bool ((pgconn* conn) (nonnull-c-string query)
    417                 (int num) (scheme-object params) (int resfmt))
    418           "int res = 0, i = 0, *lens = NULL; \n"
    419           "Oid *types = NULL; \n"
    420           "char **vals = NULL; \n"
    421           "int *fmts = NULL; \n"
    422           "C_word obj, cons; \n"
    423           "if (num > 0) { \n"
    424           "    types = C_malloc(num * sizeof(Oid)); \n"
    425           "    vals = C_malloc(num * sizeof(char *)); \n"
    426           "    lens = C_malloc(num * sizeof(int)); \n"
    427           "    fmts = C_malloc(num * sizeof(int)); \n"
    428           "} \n"
    429           "for (i=0,cons=params; i < num; ++i,cons=C_u_i_cdr(cons)) { \n"
    430           "    obj = C_u_i_car(cons); \n"
    431           "    types[i] = C_num_to_int(C_u_i_cdr(obj)); \n"
    432           "    if (C_u_i_car(obj) == C_SCHEME_FALSE) { \n"
    433           "        fmts[i] = 0; /* don't care */ \n"
    434           "        lens[i] = 0; \n"
    435           "        vals[i] = NULL; \n"
    436           "    } else if (C_header_bits(C_u_i_car(obj)) == C_BYTEVECTOR_TYPE) { \n"
    437           "        fmts[i] = 1; /* binary */ \n"
    438           "        lens[i] = C_header_size(C_u_i_car(obj)); \n"
    439           "        vals[i] = C_c_string(C_u_i_car(obj)); \n"
    440           "    } else { \n"
    441           "        /* text needs to be copied; it expects ASCIIZ */ \n"
    442           "        fmts[i] = 0; /* text */ \n"
    443           "        lens[i] = C_header_size(C_u_i_car(obj)); \n"
    444           "        vals[i] = malloc(lens[i] + 1);"
    445           "        memcpy(vals[i], C_c_string(C_u_i_car(obj)), lens[i]); \n"
    446           "        vals[i][lens[i]] = '\\0'; \n"
    447           "    }"
    448           "} \n"
    449           "res = PQsendQueryParams(conn, query, num, "
    450           "                        types, vals, lens, fmts, resfmt); \n"
    451           "for (i=0,cons=params; i < num; ++i,cons=C_u_i_cdr(cons)) { \n"
    452           "    obj = C_u_i_car(cons); \n"
    453           "    if (!C_immediatep(C_u_i_car(obj)) && \n"
    454           "         C_header_bits(C_u_i_car(obj)) == C_STRING_TYPE) \n"
    455           "        free(vals[i]); /* Clear copied strings only */ \n"
    456           "}"
    457           "if (num > 0) { \n"
    458           "    free(fmts); \n"
    459           "    free(lens); \n"
    460           "    free(vals); \n"
    461           "    free(types); \n"
    462           "} \n"
    463           "C_return(res);")))
     582(define (exec-query conn query #!optional (params '()) #!key (format 'text) raw)
     583  (let* ((unparsers (pg-connection-type-unparsers conn))
     584         (unparse (lambda (x)
     585                    (cond (raw x)
     586                          ((find (lambda (parse?)
     587                                   ((car parse?) x))
     588                                 unparsers) => (lambda (parse)
     589                                                 ((cdr parse) x)))
     590                          (else x))))
     591         (params ;; Check all params and ensure they are proper pairs
     592          (map   ;; See if this can be moved into C
     593           (lambda (p)
     594             (let ((obj (unparse (if (pair? p) (car p) p)))
     595                   (oid (if (pair? p) (cdr p) 0)))
     596               (when (and (not (string? obj))
     597                          (not (blob? obj))
     598                          (not (sql-null? obj)))
     599                 (postgresql-error
     600                  'exec-query (sprintf "Param value is not a string, sql-null or blob: ~S" p)
     601                  conn query params format))
     602               (when (not (integer? oid))
     603                 (postgresql-error
     604                  'exec-query (sprintf "Param type is not an oid: ~S" p)
     605                  conn query params format))
     606               (if (sql-null? obj) (cons #f oid) (cons obj oid)))) params))
     607         (send-query
     608          (foreign-lambda*
     609           bool ((pgconn* conn) (nonnull-c-string query)
     610                 (int num) (scheme-object params) (int resfmt))
     611           "int res = 0, i = 0, *lens = NULL;"
     612           "Oid *types = NULL;"
     613           "char **vals = NULL;"
     614           "int *fmts = NULL;"
     615           "C_word obj, cons;"
     616           "if (num > 0) {"
     617           "    types = C_malloc(num * sizeof(Oid));"
     618           "    vals = C_malloc(num * sizeof(char *));"
     619           "    lens = C_malloc(num * sizeof(int));"
     620           "    fmts = C_malloc(num * sizeof(int));"
     621           "}"
     622           "for (i=0,cons=params; i < num; ++i,cons=C_u_i_cdr(cons)) {"
     623           "    obj = C_u_i_car(cons);"
     624           "    types[i] = C_num_to_int(C_u_i_cdr(obj));"
     625           "    if (C_u_i_car(obj) == C_SCHEME_FALSE) {"
     626           "        fmts[i] = 0; /* don't care */"
     627           "        lens[i] = 0;"
     628           "        vals[i] = NULL;"
     629           "    } else if (C_header_bits(C_u_i_car(obj)) == C_BYTEVECTOR_TYPE) {"
     630           "        fmts[i] = 1; /* binary */"
     631           "        lens[i] = C_header_size(C_u_i_car(obj));"
     632           "        vals[i] = C_c_string(C_u_i_car(obj));"
     633           "    } else {"
     634           "        /* text needs to be copied; it expects ASCIIZ */"
     635           "        fmts[i] = 0; /* text */"
     636           "        lens[i] = C_header_size(C_u_i_car(obj));"
     637           "        vals[i] = malloc(lens[i] + 1);"
     638           "        memcpy(vals[i], C_c_string(C_u_i_car(obj)), lens[i]);"
     639           "        vals[i][lens[i]] = '\\0';"
     640           "    }"
     641           "}"
     642           "res = PQsendQueryParams(conn, query, num, "
     643           "                        types, vals, lens, fmts, resfmt);"
     644           "for (i=0,cons=params; i < num; ++i,cons=C_u_i_cdr(cons)) {"
     645           "    obj = C_u_i_car(cons);"
     646           "    if (!C_immediatep(C_u_i_car(obj)) &&"
     647           "         C_header_bits(C_u_i_car(obj)) == C_STRING_TYPE)"
     648           "        free(vals[i]); /* Clear copied strings only */"
     649           "}"
     650           "if (num > 0) {"
     651           "    free(fmts);"
     652           "    free(lens);"
     653           "    free(vals);"
     654           "    free(types);"
     655           "}"
     656           "C_return(res);")))
    464657   (if (send-query (pg-connection-ptr conn) query
    465                    (length params) params (if (eq? 'binary format) 1 0))
     658                   (length params) params (symbol->format format))
    466659       (car (collect-results conn)) ;; assumed to always return one result...
    467660       (postgresql-error 'exec-query
     
    477670  (define %escape-string-conn
    478671    ;; This could be more efficient by copying straight into a Scheme object.
    479     ;; Now it's being copied by PQescapeStringConn, and Chicken copies it again
     672    ;; Now it's being copied by PQescapeStringConn, and Chicken copies it again.
    480673    ;; This can allocate up to twice as much memory than the string actually
    481674    ;; uses; in extreme cases this could be a problem.
     
    534727                        "Byte array unescaping failed (out of memory?)" str)))
    535728
    536 ;;;;;;;;;;;;;;;;;;;;;;;;;;;
    537 ;;;; Old stuff to look at
    538 ;;;;;;;;;;;;;;;;;;;;;;;;;;;
    539 
    540 (define (make-value-parsers result nfields)
    541   (do ([col 0 (+ col 1)]
    542        [parsers (make-vector nfields)])
    543       ([= col nfields] parsers)
    544     (vector-set! parsers col
    545                  (hash-table-ref type-hash (PQftype result col)
    546                                  (lambda () text-parser)))))
    547 
    548 (define named-tuples (make-parameter #f))
    549 
    550 (define (query-fold-left query conn fold-function . seeds)
    551   #;(buffer-available-input! conn query)
    552 
    553   (let ([results (collect-results conn)]
    554         [seed-count (length seeds)])
    555 
    556     (let process-result ([results results]
    557                          [seeds seeds])
    558 
    559       (if (null? results)
    560           (apply values seeds)
    561           (let* ([result (car results)]
    562                  [result-status (PQresultStatus result)])
    563              
    564             (cond
    565              ;; No tuples returned.  Instead of tuple, provide the
    566              ;; number of tuples affected by the query:
    567              [(= result-status PGRES_COMMAND_OK)
    568               (let ([ntuples (string->number (PQcmdTuples result))])
    569                 (receive (proceed? . new-seeds)
    570                   (apply fold-function ntuples seeds)
    571                   (cond [(= (length new-seeds) seed-count)
    572                          (if proceed?
    573                              (process-result (cdr results) new-seeds)
    574                              (apply values new-seeds))]
    575                         [else
    576                          (error "Wrong seed count"
    577                                 `(expected ,seed-count)
    578                                 `(got ,(length new-seeds)))])))]
    579 
    580              ;; 0 or more tuples were returned.
    581              [(= result-status PGRES_TUPLES_OK)
    582               (let* ([nfields (PQnfields result)]
    583                      [ntuples (PQntuples result)]
    584                      [value-parsers (make-value-parsers
    585                                      result nfields)])
    586              
    587                 (define (get-value row column)
    588                   (if (PQgetisnull result row column)
    589                       (sql-null)
    590                       (let ([value (PQgetvalue result row column)]
    591                             [value-length (void)
    592                              #;(PQgetlength result row column)])
    593                         ((vector-ref value-parsers column)
    594                          value value-length))))
    595              
    596                 (let process-row ([row 0]
    597                                   [seeds seeds])
    598 
    599                   (if (= row ntuples)
    600                       (process-result (cdr results) seeds)
    601                       (let ([tuple (make-vector nfields)]
    602                             [get-value* (if (named-tuples)
    603                                             (lambda (row col)
    604                                               (cons (string->symbol (PQfname result col))
    605                                                     (get-value row col)))
    606                                             get-value)])
    607                            
    608                         (do ([col 0 (+ col 1)])
    609                             ([= col nfields])
    610                           (vector-set! tuple col (get-value* row col)))
    611                          
    612                         (receive (proceed? . new-seeds)
    613                           (apply fold-function tuple seeds)
    614                           (cond
    615                            [(= (length new-seeds) seed-count)
    616                             (if proceed?
    617                                 (process-row (+ row 1) new-seeds)
    618                                 (apply values new-seeds))]
    619                            [else
    620                             (error "Wrong seed count"
    621                                    `(expected ,seed-count)
    622                                    `(got ,(length new-seeds)))]))))))]
    623 
    624              [(= result-status PGRES_EMPTY_QUERY)
    625               (postgresql-error 'query-fold-left "Empty query")]
    626 
    627              [else
    628               (postgresql-error 'query-fold-left
    629                                 "Unsupported result type:"
    630                                 result-status)]))))))
    631 
    632 (define (query-for-each proc query connection)
    633   (receive ()
    634       (query-fold-left query connection
    635                           (lambda (tuple)
    636                             (proc tuple)
    637                             #t))
    638     (void)))
    639 
    640 (define (query-tuples query connection)
    641   (reverse!
    642    (query-fold-left query connection
    643                        (lambda (tuple tuples)
    644                          (values #t (cons tuple tuples)))
    645                        '())))
    646 
    647 (define (text-parser pointer len)
    648   (do ([i 0 (+ i 1)]
    649        [result-string (make-string len)]
    650        [value pointer (pointer-offset value 1)])
    651       ([= i len] result-string)
    652     (string-set! result-string i
    653                  (integer->char (pointer-u8-ref value)))))
    654 
    655 (define (char-parser pointer len)
    656   (integer->char (pointer-u8-ref pointer)))
    657 
    658 (define (bool-parser pointer len)
    659   (case (char-parser pointer len)
    660     ((#\t) #t)
    661     ((#\f) #f)))
    662 
    663 (define (abstime-parser pointer len)
    664   (text-parser pointer len))
    665 
    666 (define (reltime-parser pointer len)
    667   (text-parser pointer len))
    668 
    669 (define (parse-format-string s)
    670   (let-syntax ((push! (syntax-rules ()
    671                         ((_ value place)
    672                          (set! place (cons value place))))))
    673     (do ([i 0 (+ i 1)]
    674          [ranges (list)]
    675          [cur-range (list)]
    676          [len (string-length s)])
    677         ([= i len]
    678          (when (not (null? cur-range))
    679            (push! (cons (- i (length cur-range)) i)
    680                   ranges))
    681          (reverse! ranges))
    682       (let ([char (string-ref s i)])
    683         (cond ([and (or (null? cur-range)
    684                         (char=? char (car cur-range)))
    685                     (char-alphabetic? char)]
    686                (push! char cur-range))
    687               ([and (not (null? cur-range))
    688                     (not (char=? char (car cur-range)))]
    689                (push! (cons (- i (length cur-range)) i)
    690                       ranges)
    691                (set! cur-range
    692                      (if (char-alphabetic? char)
    693                          (list char)
    694                          (list)))))))))
    695 
    696 (define-syntax define-time-parser
    697   (syntax-rules ()
    698     ((_ name format-string)
    699      (define name
    700        (let ([format-ranges (parse-format-string format-string)])
    701          (lambda (pointer length)
    702            (let ([date-string (text-parser pointer length)])
    703              (apply
    704               vector
    705               (map (lambda (range)
    706                      (if (> (cdr range) (string-length date-string))
    707                          0
    708                          (string->number
    709                           (substring date-string (car range) (cdr range)))))
    710                    format-ranges)))))))))
    711 
    712 (define-time-parser date-parser "YYYY-MM-DD")
    713 (define-time-parser timestamp-parser "YYYY-MM-DD hh:mm:ss.ssssss")
    714 (define-time-parser timestamp/tz-parser "YYYY-MM-DD hh:mm:ss.sssssszzz")
    715 (define-time-parser time-parser "hh:mm:ss.ssssss")
    716 
    717 (define (interval-parser pointer len)
    718   (text-parser pointer len))
    719 
    720 (define (numeric-parser pointer len)
    721   (let* ([num-string (text-parser pointer len)]
    722          [num (string->number num-string)])
    723     (if num
    724         num
    725         (postgresql-error 'numeric-parser
    726                           "Unable to parse the number" num-string))))
    727 
    728 (define type-map
    729   `(("text" . ,text-parser)
    730     ("bytea" . ,text-parser)
    731     ("char" . ,char-parser)
    732     ("bpchar" . ,text-parser)
    733     ("bool" . ,bool-parser)
    734     ("int8" . ,numeric-parser)
    735     ("int4" . ,numeric-parser)
    736     ("int2" . ,numeric-parser)
    737     ("float4" . ,numeric-parser)
    738     ("float8" . ,numeric-parser)
    739     ("abstime" . ,abstime-parser)
    740     ("reltime" . ,reltime-parser)
    741     ("date" . ,date-parser)
    742     ("time" . ,time-parser)
    743     ("timestamp" . ,timestamp-parser)
    744     ("timestamptz" . ,timestamp/tz-parser)
    745     ("interval" . ,interval-parser)
    746     ("numeric" . ,numeric-parser)
    747     ("oid" . ,numeric-parser)))
    748 
    749 (define type-hash (make-hash-table))
    750 
    751 ;; Retrieve type-oids from PostgreSQL:
    752 (define (fixup-types connection)
    753   (query-for-each
    754    (lambda (parameters)
    755      (let* ([oid (string->number (vector-ref parameters 0))]
    756             [typname (vector-ref parameters 1)]
    757             [procedure (assoc typname type-map)])
    758        (when procedure
    759          (hash-table-set! type-hash oid (cdr procedure)))))
    760    "SELECT oid, typname FROM pg_type"
    761    connection))
     729
     730;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     731;;;; High-level interface
     732;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     733
     734(define (query-fold kons knil conn query #!optional (params '()))
     735  (let* ((result (exec-query conn query params))
     736         (rows (result-row-count result)))
     737    (let loop ((seed knil)
     738               (row 0))
     739      (if (= row rows)
     740          seed
     741          (loop (kons (result-values result row) seed) (add1 row))))))
     742
     743(define (query-fold* kons knil conn query #!optional (params '()))
     744  (query-fold (lambda (values seed) (apply kons (append values (list seed))))
     745              knil conn query params))
     746
     747(define (query-for-each proc conn query #!optional (params '()))
     748  (query-fold (lambda (values seed) (proc values)) #f conn query params)
     749  (void))
     750
     751(define (query-for-each* proc conn query #!optional (params '()))
     752  (query-fold (lambda (values seed) (apply proc values)) #f conn query params)
     753  (void))
    762754
    763755)
  • release/4/postgresql/trunk/tests/run.scm

    r14726 r14753  
    1 (use test postgresql sql-null)
     1(use test postgresql sql-null srfi-4)
    22
    33;; These tests assume that the current UNIX user has access to a database
     
    3838  (test "Correct row count"
    3939        2
    40         (result-rows (exec-query conn "SELECT 1 UNION SELECT 2")))
     40        (result-row-count (exec-query conn "SELECT 1 UNION SELECT 2")))
    4141  (test "Correct column count"
    4242        4
    43         (result-columns (exec-query conn "SELECT 1, 2, 3, 4")))
     43        (result-column-count (exec-query conn "SELECT 1, 2, 3, 4")))
    4444  (test "Correct column name"
    4545        "one"
    46         (result-column-name
     46        (result-column
    4747         (exec-query conn "SELECT 1 AS one, 2 AS two") 0))
     48  (test "Correct column names"
     49        '("one" "two")
     50        (result-columns
     51         (exec-query conn "SELECT 1 AS one, 2 AS two")))
    4852  (test-error "Condition for nonexistant column index"
    4953              (result-column-name
     
    5155  (test "Not false for nameless column"
    5256        #f ;; Could check for "?column?", but that's a bit too specific
    53         (not (result-column-name
     57        (not (result-column
    5458              (exec-query conn "SELECT 1, 2") 0)))
    5559  ;; Maybe add a few tests here for case folding/noncase folding variants?
     
    106110        (result-value
    107111         (exec-query conn "SELECT 'test'") 0 0))
    108   (test "Result value string for numbers"
     112  (test "Result values"
     113        '("one" "two" "three")
     114        (result-values
     115         (exec-query conn "SELECT 'one', 'two', 'three'") 0))
     116  (test "Result value number for numbers"
     117        1
     118        (result-value
     119         (exec-query conn "SELECT 1") 0 0))
     120  (test "Result value string for raw numbers"
    109121        "1"
    110122        (result-value
    111          (exec-query conn "SELECT 1") 0 0))
     123         (exec-query conn "SELECT 1") 0 0 raw: #t))
    112124  ;; We are using two levels of escaping here because the ::bytea cast
    113125  ;; performs another string interpretation. Yes, this is kinda confusing...
    114   (test "Result value for null-terminated normal string"
    115         "h\\000ello" ;; This would then be decoded using unescape-bytea
     126  (test "Result value for null-terminated byte array"
     127        (blob->u8vector (string->blob "h\x00ello"))
    116128        (result-value
    117129         (exec-query conn "SELECT E'h\\\\000ello'::bytea") 0 0))
     130  (test "Result value for raw null-terminated byte array"
     131        "h\\000ello"
     132        (result-value
     133         (exec-query conn "SELECT E'h\\\\000ello'::bytea") 0 0 raw: #t))
    118134
    119135  (test "Result value blob for binary string"
     
    192208        "hi"
    193209        (result-value (exec-query conn "SELECT $1::text" `(,(string->blob "hi"))) 0 0))
     210  (test "boolean parameters"
     211        '(#t #f)
     212        (result-values (exec-query conn "SELECT $1::bool, $2::bool" '(#t #f)) 0 0))
    194213  (test "parameters with OID"
    195         "1"
     214        1
    196215        (result-value (exec-query conn "SELECT $1" '(("1" . 23))) 0 0)))
    197216
     
    208227        ;; by pgsql either.
    209228        (unescape-bytea "What's\\012up?")))
     229
     230(test-group "high-level interface"
     231  (test "query-fold"
     232        '(("one" "two")
     233          ("three" "four"))
     234        (reverse
     235         (query-fold cons '()
     236                     conn "SELECT 'one', 'two' UNION SELECT 'three', 'four'"))))
Note: See TracChangeset for help on using the changeset viewer.