Changeset 14721 in project


Ignore:
Timestamp:
05/21/09 15:24:19 (10 years ago)
Author:
sjamaan
Message:

Implement more result stuff, up until value retrieval

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

Legend:

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

    r14678 r14721  
    2323  escape-string exec-query
    2424  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  invalid-oid
    2528  query-fold-left query-for-each query-tuples named-tuples)
    2629
     
    6366;(define-foreign-type oid "Oid")
    6467(define-foreign-type oid unsigned-int)
     68
     69(define invalid-oid (foreign-value "InvalidOid" oid))
    6570
    6671;; TODO: Add define-foreign-type for creating the lists of oids/value strings
     
    95100(define PQfname (foreign-lambda c-string PQfname (const pgresult*) int))
    96101(define PQfnumber (foreign-lambda int PQfnumber (const pgresult*) (const c-string)))
     102(define PQftable (foreign-lambda oid PQftable (const pgresult*) int))
     103(define PQftablecol (foreign-lambda int PQftablecol (const pgresult*) int))
     104(define PQfformat (foreign-lambda int PQfformat (const pgresult*) int))
     105(define PQftype (foreign-lambda oid PQftype (const pgresult*) int))
     106(define PQfmod (foreign-lambda int PQfmod (const pgresult*) int))
    97107(define PQcmdTuples (foreign-lambda nonnull-c-string PQcmdTuples pgresult*))
    98 (define PQftype (foreign-lambda oid PQftype (const pgresult*) int))
    99108
    100109(define PQgetvalue (foreign-lambda (c-pointer char) PQgetvalue (const pgresult*) int int))
     
    244253  (PQnfields (pg-result-ptr result)))
    245254
     255;; Helper procedures for bounds checking; so we can distinguish between
     256;; out of bounds and nonexistant columns, and signal it.
     257(define (check-result-column-index! result index location)
     258  (when (>= index (result-columns result))
     259    (postgresql-error
     260     location (sprintf "Result column ~A out of bounds" index) result index)))
     261
     262(define (check-result-row-index! result index location)
     263  (when (>= index (result-rows result))
     264    (postgresql-error
     265     location (sprintf "Result row ~A out of bounds" index) result index)))
     266
    246267(define (result-column-name result index)
     268  (check-result-column-index! result index 'result-column-name)
    247269  (PQfname (pg-result-ptr result) index))
    248270
     
    250272  (let ((idx (PQfnumber (pg-result-ptr result) name)))
    251273    (and (>= idx 0) idx)))
     274
     275(define (result-table-oid result index)
     276  (check-result-column-index! result index 'result-table-oid)
     277  (let ((oid (PQftable (pg-result-ptr result) index)))
     278    (and (not (= oid invalid-oid)) oid)))
     279
     280;; Fixes the off-by-1 unexpectedness in libpq/the protocol to make it more
     281;; consistent with the rest of Scheme.  However, this is inconsistent with
     282;; almost all other PostgreSQL interfaces...
     283(define (result-table-column-index result index)
     284  (check-result-column-index! result index 'result-table-column-index)
     285  (let ((idx (PQftablecol (pg-result-ptr result) index)))
     286    (and (> idx 0) (sub1 idx))))
     287
     288(define (result-column-format result index)
     289  (check-result-column-index! result index 'result-column-format)
     290  (let ((type (alist-ref (PQfformat (pg-result-ptr result) index)
     291                         '((0 . text) (1 . binary)))))
     292    (or type
     293        (postgresql-error 'result-column-format
     294                          (conc "Unknown column type " type)
     295                          result index))))
     296
     297(define (result-column-type result index)
     298  (check-result-column-index! result index 'result-column-type)
     299  (PQftype (pg-result-ptr result) index))
     300
     301;; This is really not super-useful as it requires intimate knowledge
     302;; about the internal implementations of types in PostgreSQL.
     303(define (result-column-type-modifier result index)
     304  (check-result-column-index! result index 'result-column-type)
     305  (let ((mod (PQfmod (pg-result-ptr result) index)))
     306    (and (>= mod 0) mod)))
     307
     308(define (result-value result row column)
     309  (check-result-row-index! result row 'result-value)
     310  (check-result-column-index! result column 'result-value)
     311  (if (PQgetisnull (pg-result-ptr result) row column)
     312      (sql-null)
     313      ((foreign-safe-lambda*
     314        scheme-object ((c-pointer res)
     315                       (int row)
     316                       (int col))
     317        "C_word *fin; char *val; int len;"
     318        "len = PQgetlength(res, row, col);"
     319        "fin = C_alloc(C_bytestowords(len + sizeof(C_header)));"
     320        "val = PQgetvalue(res, row, col);"
     321        "C_return(C_string(&fin, len, val));")
     322       (pg-result-ptr result) row column)))
    252323
    253324;; Buffer all available input, yielding if nothing is available:
     
    265336                            conn-ptr)))))
    266337
    267 ;; Collect the result pointers from the last query:
     338;; Collect the result pointers from the last query.
     339;;
     340;; A pgresult represents an entire resultset and is always read into memory
     341;; all at once.
    268342(define (collect-results conn)
    269343  (buffer-available-input! conn)
  • release/4/postgresql/trunk/tests/run.scm

    r14678 r14721  
    1 (use test postgresql)
     1(use test postgresql sql-null)
    22
    33;; These tests assume that the current UNIX user has access to a database
     
    4747        (result-column-name
    4848         (car (exec-query conn "SELECT 1 AS one, 2 AS two")) 0))
    49   (test "False for nonexistant column index"
    50         #f
    51         (result-column-name
    52          (car (exec-query conn "SELECT 1 AS one, 2 AS two")) 3))
     49  (test-error "Condition for nonexistant column index"
     50              (result-column-name
     51               (car (exec-query conn "SELECT 1 AS one, 2 AS two")) 3))
     52  (test "Not false for nameless column"
     53        #f ;; Could check for "?column?", but that's a bit too specific
     54        (not (result-column-name
     55              (car (exec-query conn "SELECT 1, 2")) 0)))
    5356  ;; Maybe add a few tests here for case folding/noncase folding variants?
    5457  ;; Perhaps result-column-index-ci vs result-column-index?  That would be
     
    5962        (result-column-index
    6063         (car (exec-query conn "SELECT 1 AS one, 2 AS two")) "one"))
    61   (test "False for nonexistant column name"
     64  (test "False column index for nonexistant column name"
    6265        #f
    6366        (result-column-index
    64          (car (exec-query conn "SELECT 1 AS one, 2 AS two")) "foo")))
     67         (car (exec-query conn "SELECT 1 AS one, 2 AS two")) "foo"))
     68  (test "False oid for virtual table"
     69        #f
     70        (result-table-oid
     71         (car (exec-query conn "SELECT 1 AS one, 2 AS two")) 0))
     72  (test-assert "Number for nonvirtual table"
     73               (number?
     74                (result-table-oid
     75                 (car (exec-query conn "SELECT typlen FROM pg_type")) 0)))
     76  (test-error "Condition for column index out of bounds"
     77              (result-table-oid
     78               (car (exec-query conn "SELECT typname FROM pg_type")) 1))
     79  (test "Table column number for real table"
     80        0
     81        (result-table-column-index
     82         (car (exec-query conn "SELECT typname FROM pg_type")) 0))
     83  (test "Column format is text for normal data"
     84        'text
     85        (result-column-format
     86         (car (exec-query conn "SELECT 'hi'")) 0))
     87  ;; The only easy way to get a binary column is by creating a binary cursor
     88  (test "Column format is binary for forced binary data"
     89        'binary
     90        (result-column-format
     91         (cadr (exec-query conn
     92                           (conc "DECLARE b1 BINARY CURSOR FOR SELECT 'hi';"
     93                                 "FETCH FORWARD 1 FROM b1;"
     94                                 "CLOSE b1"))) 0))
     95  (test "Column type OID ok"
     96        23 ;; from catalog/pg_type.h
     97        (result-column-type
     98         (car (exec-query conn "SELECT 1::int4")) 0))
     99  (test "Column modifier false"
     100        #f
     101        (result-column-type-modifier
     102         (car (exec-query conn "SELECT 1")) 0))
     103  (test "Column modifier for bit ok"
     104        2
     105        (result-column-type-modifier
     106         (car (exec-query conn "SELECT '10'::bit(2)")) 0))
     107  (test "Result value string for strings"
     108        "test"
     109        (result-value
     110         (car (exec-query conn "SELECT 'test'")) 0 0))
     111  (test "Result value string for numbers"
     112        "1"
     113        (result-value
     114         (car (exec-query conn "SELECT 1")) 0 0))
     115  (test "Result value string for binary values"
     116        "hi"
     117        (result-value
     118         (cadr (exec-query conn
     119                           (conc "DECLARE b1 BINARY CURSOR FOR SELECT 'hi';"
     120                                 "FETCH FORWARD 1 FROM b1;"
     121                                 "CLOSE b1"))) 0 0))
     122  (test-assert "Result value sql-null for NULL"
     123               (sql-null? (result-value
     124                           (car (exec-query conn "SELECT NULL")) 0 0)))
     125  (test-error "Result value error for out of bounds column"
     126              (result-value
     127               (car (exec-query conn "SELECT NULL")) 0 1))
     128  (test-error "Result value error for out of bounds row"
     129              (result-value
     130               (car (exec-query conn "SELECT NULL")) 1 0)))
Note: See TracChangeset for help on using the changeset viewer.