Changeset 14726 in project


Ignore:
Timestamp:
05/22/09 01:55:26 (10 years ago)
Author:
sjamaan
Message:

Implement separate parameter passing and the option to explicitly request binary return values.
Old exec-query is now renamed to exec-simple-queries, as it only allows simple queries with no params and no return format, but does allow multiple queries in one string.

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

Legend:

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

    r14725 r14726  
    2121(module postgresql
    2222 (connect reset-connection disconnect connection?
    23   exec-query
     23  exec-simple-queries exec-query
    2424  result? result-rows result-columns result-column-name result-column-index
    2525  result-table-oid result-table-column-index result-column-format
     
    6363(define PQfinish (foreign-lambda void PQfinish pgconn*))
    6464(define PQstatus (foreign-lambda (enum "ConnStatusType") PQstatus (const pgconn*)))
    65 (define PQsendQuery (foreign-lambda bool PQsendQuery pgconn* (const c-string)))
    6665(define PQerrorMessage (foreign-lambda c-string PQerrorMessage (const pgconn*)))
    6766
     
    7069
    7170(define invalid-oid (foreign-value "InvalidOid" oid))
    72 
    73 ;; TODO: Add define-foreign-type for creating the lists of oids/value strings
    74 #;(define PQsendQueryParams
    75   (foreign-lambda bool PQsendQueryParams
    76                   ;; conn  command          nParams
    77                   pgconn*  (const c-string) int
    78                   ;; paramTypes
    79                   (const (nonnull-c-pointer oid))
    80                   ;; paramValues
    81                   (const c-string-list)
    82                   ;; paramLengths
    83                   (const (nonnull-c-pointer int))
    84                   ;; paramFormats
    85                   (const (nonnull-c-pointer int))
    86                   ;; resultFormat
    87                   int))
    8871
    8972(define PQisBusy (foreign-lambda bool PQisBusy pgconn*))
     
    313296      (sql-null)
    314297      ((foreign-safe-lambda*
    315         scheme-object ((c-pointer res)
    316                        (int row)
    317                        (int col))
     298        scheme-object ((c-pointer res) (int row) (int col))
    318299        "C_word fin, *str; char *val; int len;"
    319300        "len = PQgetlength(res, row, col);"
     
    403384          (reverse! results)))))
    404385
     386
    405387;; TODO: Ensure that no two queries can be issued at the same time! (thread lock)
    406388;; This is needed because there's always only one "active" query.
    407 (define (exec-query conn query)
    408   (if (PQsendQuery (pg-connection-ptr conn) query)
     389(define (exec-simple-queries conn query)
     390  (if ((foreign-lambda bool PQsendQuery pgconn* (const c-string))
     391       (pg-connection-ptr conn) query)
    409392      (collect-results conn)
    410393      (postgresql-error 'exec-query!
     
    412395                              (PQerrorMessage (pg-connection-ptr conn)))
    413396                        conn query)))
     397
     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);")))
     464   (if (send-query (pg-connection-ptr conn) query
     465                   (length params) params (if (eq? 'binary format) 1 0))
     466       (car (collect-results conn)) ;; assumed to always return one result...
     467       (postgresql-error 'exec-query!
     468                         (conc "Unable to send query to server. "
     469                               (PQerrorMessage (pg-connection-ptr conn)))
     470                         conn query params format))))
    414471
    415472;;;;;;;;;;;;;;;;;;;;;;
     
    704761   connection))
    705762
    706 ;;; query with params stuff
    707 
    708 #;(define (pq-send-query-params conn query-args #!key (format 'text))
    709   ;; first attempt: all args will be text. I'll look at binary later.
    710   (let* ((query (car query-args))
    711          (args (map ->string (cdr query-args)))
    712          (pcount (length args))
    713          (pvalues (map ->string args))
    714          (plengths (list->s32vector (map string-length args)))
    715          (pformats (list->s32vector (map (constantly 0) args))) ; 1 for binary, 0 for text.
    716          (ptypes (list->u32vector (map (constantly 0) args)))
    717          (result (PQsendQueryParams conn query
    718                                     pcount ptypes pvalues plengths pformats
    719                                     (if (eq? format 'text) 0 1))))
    720     result))
    721763)
  • release/4/postgresql/trunk/tests/run.scm

    r14725 r14726  
    3131
    3232(test-group "low-level interface"
    33   (test "simple query returns one result"
    34         1
    35         (length (exec-query conn "SELECT 1")))
    36   (test "multi-query returns more results"
    37         3
    38         (length (exec-query conn "SELECT 1; SELECT 'hello'; SELECT TRUE")))
     33  (test-assert "query returns result"
     34               (result? (exec-query conn "SELECT 1")))
     35  (test "simple queries return several results"
     36        2
     37        (length (exec-simple-queries conn "SELECT 10; SELECT 100")))
    3938  (test "Correct row count"
    4039        2
    41         (result-rows (car (exec-query conn "SELECT 1 UNION SELECT 2"))))
     40        (result-rows (exec-query conn "SELECT 1 UNION SELECT 2")))
    4241  (test "Correct column count"
    4342        4
    44         (result-columns (car (exec-query conn "SELECT 1, 2, 3, 4"))))
     43        (result-columns (exec-query conn "SELECT 1, 2, 3, 4")))
    4544  (test "Correct column name"
    4645        "one"
    4746        (result-column-name
    48          (car (exec-query conn "SELECT 1 AS one, 2 AS two")) 0))
     47         (exec-query conn "SELECT 1 AS one, 2 AS two") 0))
    4948  (test-error "Condition for nonexistant column index"
    5049              (result-column-name
    51                (car (exec-query conn "SELECT 1 AS one, 2 AS two")) 3))
     50               (exec-query conn "SELECT 1 AS one, 2 AS two") 3))
    5251  (test "Not false for nameless column"
    5352        #f ;; Could check for "?column?", but that's a bit too specific
    5453        (not (result-column-name
    55               (car (exec-query conn "SELECT 1, 2")) 0)))
     54              (exec-query conn "SELECT 1, 2") 0)))
    5655  ;; Maybe add a few tests here for case folding/noncase folding variants?
    5756  ;; Perhaps result-column-index-ci vs result-column-index?  That would be
     
    6160        0
    6261        (result-column-index
    63          (car (exec-query conn "SELECT 1 AS one, 2 AS two")) "one"))
     62         (exec-query conn "SELECT 1 AS one, 2 AS two") "one"))
    6463  (test "False column index for nonexistant column name"
    6564        #f
    6665        (result-column-index
    67          (car (exec-query conn "SELECT 1 AS one, 2 AS two")) "foo"))
     66         (exec-query conn "SELECT 1 AS one, 2 AS two") "foo"))
    6867  (test "False oid for virtual table"
    6968        #f
    7069        (result-table-oid
    71          (car (exec-query conn "SELECT 1 AS one, 2 AS two")) 0))
     70         (exec-query conn "SELECT 1 AS one, 2 AS two") 0))
    7271  (test-assert "Number for nonvirtual table"
    7372               (number?
    7473                (result-table-oid
    75                  (car (exec-query conn "SELECT typlen FROM pg_type")) 0)))
     74                 (exec-query conn "SELECT typlen FROM pg_type") 0)))
    7675  (test-error "Condition for column index out of bounds"
    7776              (result-table-oid
    78                (car (exec-query conn "SELECT typname FROM pg_type")) 1))
     77               (exec-query conn "SELECT typname FROM pg_type") 1))
    7978  (test "Table column number for real table"
    8079        0
    8180        (result-table-column-index
    82          (car (exec-query conn "SELECT typname FROM pg_type")) 0))
     81         (exec-query conn "SELECT typname FROM pg_type") 0))
    8382  (test "Column format is text for normal data"
    8483        'text
    8584        (result-column-format
    86          (car (exec-query conn "SELECT 'hello'")) 0))
    87   ;; The only easy way to get a binary column is by creating a binary cursor
     85         (exec-query conn "SELECT 'hello'") 0))
     86 
    8887  (test "Column format is binary for forced binary data"
    8988        'binary
    9089        (result-column-format
    91          (cadr (exec-query conn
    92                            (conc "DECLARE b1 BINARY CURSOR FOR SELECT 'hello';"
    93                                  "FETCH FORWARD 1 FROM b1;"
    94                                  "CLOSE b1"))) 0))
     90         (exec-query conn "SELECT 1" '() format: 'binary) 0))
     91 
    9592  (test "Column type OID ok"
    9693        23 ;; from catalog/pg_type.h
    9794        (result-column-type
    98          (car (exec-query conn "SELECT 1::int4")) 0))
     95         (exec-query conn "SELECT 1::int4") 0))
    9996  (test "Column modifier false"
    10097        #f
    10198        (result-column-type-modifier
    102          (car (exec-query conn "SELECT 1")) 0))
     99         (exec-query conn "SELECT 1") 0))
    103100  (test "Column modifier for bit ok"
    104101        2
    105102        (result-column-type-modifier
    106          (car (exec-query conn "SELECT '10'::bit(2)")) 0))
     103         (exec-query conn "SELECT '10'::bit(2)") 0))
    107104  (test "Result value string for strings"
    108105        "test"
    109106        (result-value
    110          (car (exec-query conn "SELECT 'test'")) 0 0))
     107         (exec-query conn "SELECT 'test'") 0 0))
    111108  (test "Result value string for numbers"
    112109        "1"
    113110        (result-value
    114          (car (exec-query conn "SELECT 1")) 0 0))
     111         (exec-query conn "SELECT 1") 0 0))
    115112  ;; We are using two levels of escaping here because the ::bytea cast
    116113  ;; performs another string interpretation. Yes, this is kinda confusing...
     
    118115        "h\\000ello" ;; This would then be decoded using unescape-bytea
    119116        (result-value
    120          (car (exec-query conn "SELECT E'h\\\\000ello'::bytea")) 0 0))
     117         (exec-query conn "SELECT E'h\\\\000ello'::bytea") 0 0))
     118
    121119  (test "Result value blob for binary string"
    122120        (string->blob "hello")
    123121        (result-value
    124          (cadr (exec-query conn
    125                            (conc "DECLARE b1 BINARY CURSOR FOR SELECT 'hello';"
    126                                  "FETCH FORWARD 1 FROM b1;"
    127                                  "CLOSE b1"))) 0 0))
     122         (exec-query conn "SELECT 'hello'" '() format: 'binary) 0 0))
     123 
    128124  (test "Result value blob for binary integer"
    129125        (u8vector->blob (u8vector 0 0 0 1))
    130         (result-value
    131          (cadr (exec-query conn
    132                            (conc "DECLARE b1 BINARY CURSOR FOR SELECT 1::int4;"
    133                                  "FETCH FORWARD 1 FROM b1;"
    134                                  "CLOSE b1"))) 0 0))
    135   (test "Result value for null-terminated binary string"
     126        (result-value (exec-query conn "SELECT 1::int4" '() format: 'binary) 0 0))
     127
     128  (test "Result value for binary string with NUL bytes"
    136129        (string->blob "h\x00ello")
    137         (result-value
    138          (cadr (exec-query conn
    139                            (conc "DECLARE b1 BINARY CURSOR FOR SELECT E'h\\\\000ello'::bytea;"
    140                                  "FETCH FORWARD 1 FROM b1;"
    141                                  "CLOSE b1"))) 0 0))
     130        (result-value (exec-query conn "SELECT E'h\\\\000ello'::bytea" '() format: 'binary) 0 0))
     131
    142132  (test-assert "Result value sql-null for NULL"
    143133               (sql-null? (result-value
    144                            (car (exec-query conn "SELECT NULL")) 0 0)))
     134                           (exec-query conn "SELECT NULL") 0 0)))
    145135  (test-error "Result value error for out of bounds column"
    146136              (result-value
    147                (car (exec-query conn "SELECT NULL")) 0 1))
     137               (exec-query conn "SELECT NULL") 0 1))
    148138  (test-error "Result value error for out of bounds row"
    149139              (result-value
    150                (car (exec-query conn "SELECT NULL")) 1 0))
     140               (exec-query conn "SELECT NULL") 1 0))
    151141  (test "Number of affected rows false with SELECT"
    152142        #f
    153143        (result-affected-rows
    154          (car (exec-query conn "SELECT 1"))))
     144         (exec-query conn "SELECT 1")))
     145
     146  (exec-query conn "BEGIN")
     147  (exec-query conn "CREATE TEMP TABLE foo ( bar integer ) ON COMMIT DROP")
    155148  (test "Number of affected rows 1 with INSERT"
    156149        1
    157150        (result-affected-rows
    158          (third (exec-query conn (conc "BEGIN;"
    159                                        "CREATE TEMP TABLE foo "
    160                                        "( bar integer ) ON COMMIT DROP;"
    161                                        "INSERT INTO foo (bar) VALUES (1);"
    162                                        "COMMIT;")))))
     151         (exec-query conn "INSERT INTO foo (bar) VALUES (1);")))
     152  (exec-query conn "COMMIT")
     153
     154  (exec-query conn "BEGIN")
     155  (exec-query conn "CREATE TEMP TABLE foo ( bar integer ) ON COMMIT DROP")
     156  (exec-query conn "INSERT INTO foo (bar) VALUES (100);")
     157  (exec-query conn "INSERT INTO foo (bar) VALUES (101);")
    163158  (test "Number of affected rows 2 with UPDATE of two rows"
    164159        2
    165160        (result-affected-rows
    166          (fifth (exec-query conn (conc "BEGIN;"
    167                                        "CREATE TEMP TABLE foo "
    168                                        "( bar integer ) ON COMMIT DROP;"
    169                                        "INSERT INTO foo (bar) VALUES (100);"
    170                                        "INSERT INTO foo (bar) VALUES (101);"
    171                                        "UPDATE foo SET bar=102;"
    172                                        "COMMIT;")))))
     161         (exec-query conn "UPDATE foo SET bar=102;")))
     162  (exec-query conn "COMMIT")
     163 
    173164  (test "Inserted OID false on SELECT"
    174165        #f
    175166        (result-inserted-oid
    176          (car (exec-query conn "SELECT 1"))))
     167         (exec-query conn "SELECT 1")))
     168
     169  (exec-query conn "BEGIN")
     170  (exec-query conn "CREATE TEMP TABLE foo ( bar integer ) ON COMMIT DROP")
    177171  (test "Inserted OID false on OID-less table"
    178172        #f
    179173        (result-inserted-oid
    180          (third (exec-query conn (conc "BEGIN;"
    181                                        "CREATE TEMP TABLE foo "
    182                                        "( bar integer ) ON COMMIT DROP;"
    183                                        "INSERT INTO foo (bar) VALUES (1);"
    184                                        "COMMIT;")))))
    185   (test-assert
    186    "Inserted OID number on table with OID"
    187    (number?
    188     (result-inserted-oid
    189      (third (exec-query conn (conc "BEGIN;"
    190                                    "CREATE TEMP TABLE foo (bar integer) "
    191                                    "WITH (OIDS=true) ON COMMIT DROP;"
    192                                    "INSERT INTO foo (bar) VALUES (1);"
    193                                    "COMMIT;")))))))
     174         (exec-query conn  "INSERT INTO foo (bar) VALUES (1);")))
     175  (exec-query conn "COMMIT")
     176 
     177  (exec-query conn "BEGIN")
     178  (exec-query conn "CREATE TEMP TABLE foo ( bar integer ) WITH (OIDS=true) ON COMMIT DROP")
     179  (test-assert "Inserted OID number on table with OID"
     180               (number?
     181                (result-inserted-oid
     182                 (exec-query conn "INSERT INTO foo (bar) VALUES (1)"))))
     183  (exec-query conn "COMMIT")
     184
     185  (test "regular parameters"
     186        "hi"
     187        (result-value (exec-query conn "SELECT $1::text" '("hi")) 0 0))
     188  (test-assert "NULL parameters"
     189               (sql-null? (result-value
     190                           (exec-query conn "SELECT $1::text" `(,(sql-null))) 0 0)))
     191  (test "blob parameters"
     192        "hi"
     193        (result-value (exec-query conn "SELECT $1::text" `(,(string->blob "hi"))) 0 0))
     194  (test "parameters with OID"
     195        "1"
     196        (result-value (exec-query conn "SELECT $1" '(("1" . 23))) 0 0)))
    194197
    195198(test-group "value escaping"
Note: See TracChangeset for help on using the changeset viewer.