Changeset 14678 in project


Ignore:
Timestamp:
05/17/09 22:44:57 (10 years ago)
Author:
sjamaan
Message:

Start building low-level query and result set operations, corresponding to libpq functions. High-level interface will build on these

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

Legend:

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

    r14631 r14678  
    99 (hidden) ;; Not ready yet!
    1010 (license "BSD")
     11 (depends sql-null)
    1112 (test-depends test)
    1213 (files "postgresql.setup" "postgresql.html" "postgresql.scm" "tests"))
  • release/4/postgresql/trunk/postgresql.scm

    r14669 r14678  
    2020
    2121(module postgresql
    22  (connect reset-connection disconnect
    23 
    24 
    25   query-fold-left query-for-each
    26   query-tuples sql-null-object? connection? escape-string
    27   pgsql-null-object
    28   named-tuples)
     22 (connect reset-connection disconnect connection?
     23  escape-string exec-query
     24  result? result-rows result-columns result-column-name result-column-index
     25  query-fold-left query-for-each query-tuples named-tuples)
    2926
    3027(import chicken scheme foreign)
    3128
    32 (require-extension lolevel data-structures extras srfi-1 srfi-4 srfi-13 srfi-18 srfi-69)
     29(require-extension lolevel data-structures extras
     30                   srfi-1 srfi-4 srfi-13 srfi-18 srfi-69 sql-null)
    3331
    3432(foreign-declare "#include <libpq-fe.h>")
     
    6058(define PQfinish (foreign-lambda void PQfinish pgconn*))
    6159(define PQstatus (foreign-lambda (enum "ConnStatusType") PQstatus (const pgconn*)))
    62 (define PQsendQuery (foreign-lambda int PQsendQuery pgconn* (const c-string)))
     60(define PQsendQuery (foreign-lambda bool PQsendQuery pgconn* (const c-string)))
    6361(define PQerrorMessage (foreign-lambda c-string PQerrorMessage (const pgconn*)))
    6462
    65 (define-foreign-type oid unsigned-int) ;; XXX Should be an opaque type
     63;(define-foreign-type oid "Oid")
     64(define-foreign-type oid unsigned-int)
    6665
    6766;; TODO: Add define-foreign-type for creating the lists of oids/value strings
    6867#;(define PQsendQueryParams
    69   (foreign-lambda int PQsendQueryParams
     68  (foreign-lambda bool PQsendQueryParams
    7069                  ;; conn  command          nParams
    7170                  pgconn*  (const c-string) int
     
    9392(define PQclear (foreign-lambda void PQclear pgresult*))
    9493(define PQntuples (foreign-lambda int PQntuples (const pgresult*)))
    95 (define PQnfields (foreign-lambda int PQntuples (const pgresult*)))
     94(define PQnfields (foreign-lambda int PQnfields (const pgresult*)))
     95(define PQfname (foreign-lambda c-string PQfname (const pgresult*) int))
     96(define PQfnumber (foreign-lambda int PQfnumber (const pgresult*) (const c-string)))
    9697(define PQcmdTuples (foreign-lambda nonnull-c-string PQcmdTuples pgresult*))
    9798(define PQftype (foreign-lambda oid PQftype (const pgresult*) int))
    98 (define PQfname (foreign-lambda c-string PQftype (const pgresult*) int))
    9999
    100100(define PQgetvalue (foreign-lambda (c-pointer char) PQgetvalue (const pgresult*) int int))
    101101(define PQgetisnull (foreign-lambda bool PQgetisnull (const pgresult*) int int))
    102102(define PQgetlength (foreign-lambda int PQgetlength (const pgresult*) int int))
     103
     104;; TODO: Create a real callback system?
     105(foreign-declare "static void nullNoticeReceiver(void *arg, const PGresult *res){ }")
    103106
    104107(define-syntax define-foreign-int
     
    139142     'source-function source-function)))
    140143
     144;;;;;;;;;;;;;;;;;;;;;;;;
     145;;;;;; Connections
     146;;;;;;;;;;;;;;;;;;;;;;;;
     147
    141148(define-record pg-connection ptr)
    142149(define connection? pg-connection?)
    143 
    144 (define-record sql-null-object)
    145 (define pgsql-null-object (make-sql-null-object))
    146 (define (sql-null-object? x)
    147   (eq? x pgsql-null-object))
    148150
    149151(define (pgsql-connection->fd conn)
     
    198200     (else
    199201      (let ((conn (make-pg-connection conn-ptr)))
     202        ;; We don't want libpq to piss in our stderr stream
     203        ((foreign-lambda* void ((pgconn* conn))
     204          "PQsetNoticeReceiver(conn, nullNoticeReceiver, NULL);") conn-ptr)
    200205        (wait-for-connection! conn PQconnectPoll)
    201206        (set-finalizer! conn disconnect)
     
    217222(define (disconnect connection)
    218223  (and-let* ((conn-ptr (pg-connection-ptr connection)))
    219     (PQfinish conn-ptr)
    220     (pg-connection-ptr-set! connection #f))
     224    (pg-connection-ptr-set! connection #f)
     225    (PQfinish conn-ptr))
    221226  (void))
    222227
     228;;;;;;;;;;;;;;;;;;;;;
     229;;;;;; Results
     230;;;;;;;;;;;;;;;;;;;;;
     231
     232(define-record pg-result ptr)
     233(define result? pg-result?)
     234
     235(define (clear-result result)
     236  (and-let* ((result-ptr (pg-result-ptr result)))
     237    (pg-result-ptr-set! result #f)
     238    (PQclear result-ptr)))
     239
     240(define (result-rows result)
     241  (PQntuples (pg-result-ptr result)))
     242
     243(define (result-columns result)
     244  (PQnfields (pg-result-ptr result)))
     245
     246(define (result-column-name result index)
     247  (PQfname (pg-result-ptr result) index))
     248
     249(define (result-column-index result name)
     250  (let ((idx (PQfnumber (pg-result-ptr result) name)))
     251    (and (>= idx 0) idx)))
     252
    223253;; Buffer all available input, yielding if nothing is available:
    224 #;(define (buffer-available-input! conn query)
    225   (let* ([conn-ptr (pg-connection-ptr conn)]
    226          [query-reply (if (pair? query)
    227                          (pq-send-query-params conn query)
    228                          (PQsendQuery conn-ptr query))])
    229 
    230     (if (zero? query-reply)
    231         (postgresql-error 'buffer-available-input!
    232                           (sprintf "PQsendQuery: ~A"
    233                                    (string-trim-right (PQerrorMessage conn-ptr)))
    234                           query conn))
    235  
    236     (let ([conn-fd (pgsql-connection->fd conn)])
    237       (let loop ()
    238         (if (PQconsumeInput conn-ptr)
    239             (when (PQisBusy conn-ptr)
    240               (thread-wait-for-i/o! conn-fd #:input)
    241               (loop))
    242             (postgresql-error 'buffer-available-input!
    243                               (sprintf "PQconsumeInput: ~A"
    244                                        (string-trim-right
    245                                         (PQerrorMessage conn-ptr)))
    246                               conn-ptr)))
    247       (void))))
     254(define (buffer-available-input! conn)
     255  (let ((conn-ptr (pg-connection-ptr conn))
     256        (conn-fd (pgsql-connection->fd conn)))
     257    (let loop ()
     258      (if (PQconsumeInput conn-ptr)
     259          (when (PQisBusy conn-ptr)
     260            (thread-wait-for-i/o! conn-fd #:input)
     261            (loop))
     262          (postgresql-error 'buffer-available-input!
     263                            (conc "Error reading reply from server. "
     264                                  (PQerrorMessage conn-ptr))
     265                            conn-ptr)))))
    248266
    249267;; Collect the result pointers from the last query:
    250268(define (collect-results conn)
    251   (define (cleanup-results! conn)
    252     (let loop ()
    253       (let ([result (PQgetResult (pg-connection-ptr conn))])
    254         (when result
    255           (PQclear result)
    256           (loop))))
    257     (void))
    258 
    259   (let loop ([results (list)])
    260     (let* ([conn-ptr (pg-connection-ptr conn)]
    261            [result (PQgetResult conn-ptr)])
     269  (buffer-available-input! conn)
     270  (let loop ((results (list)))
     271    (let* ((conn-ptr (pg-connection-ptr conn))
     272           (result (PQgetResult conn-ptr)))
    262273      (if result
    263274          (cond
    264            [(member (PQresultStatus result) (list PGRES_BAD_RESPONSE
     275           ((member (PQresultStatus result) (list PGRES_BAD_RESPONSE
    265276                                                  PGRES_FATAL_ERROR))
    266             (let* ([msg (string-trim-right (PQresultErrorMessage result))]
    267                    [get-error-field (lambda (diag) (PQresultErrorField result diag))]
    268                    [sqlstate (get-error-field PG_DIAG_SQLSTATE)]
    269                    [maybe-severity (get-error-field PG_DIAG_SEVERITY)]
    270                    [maybe-statement-position (get-error-field PG_DIAG_STATEMENT_POSITION)]
    271                    [condition
    272                     (make-pg-condition
    273                      'collect-results
    274                      (sprintf "PQgetResult: ~A" msg)
    275                      args:               (list conn)
    276                      severity:           (and maybe-severity
    277                                               (string->symbol (string-downcase maybe-severity)))
    278                      error-class:         (and sqlstate (string-take sqlstate 2))
    279                      error-code:          sqlstate
    280                      message-detail:     (get-error-field PG_DIAG_MESSAGE_DETAIL)
    281                      message-hint:       (get-error-field PG_DIAG_MESSAGE_HINT)
    282                      statement-position:  (and maybe-statement-position
    283                                                (string->number maybe-statement-position))
    284                      context:            (get-error-field PG_DIAG_CONTEXT)
    285                      source-file:        (get-error-field PG_DIAG_SOURCE_FILE)
    286                      source-line:        (get-error-field PG_DIAG_SOURCE_LINE)
    287                      source-function:    (get-error-field PG_DIAG_SOURCE_FUNCTION))])
    288               (PQclear result)
    289               (cleanup-results! conn)
    290               (signal condition))]
    291            [else
    292             (loop (cons result results))])
     277            (let* ((msg (string-trim-right (PQresultErrorMessage result)))
     278                   (get-error-field (lambda (diag)
     279                                      (PQresultErrorField result diag)))
     280                   (sqlstate (get-error-field PG_DIAG_SQLSTATE))
     281                   (maybe-severity (get-error-field PG_DIAG_SEVERITY))
     282                   (maybe-statement-position
     283                    (get-error-field PG_DIAG_STATEMENT_POSITION))
     284                   (condition
     285                    (make-pg-condition
     286                     'collect-results
     287                     (conc "PQgetResult: " msg)
     288                     args:               (list conn)
     289                     severity:           (and maybe-severity
     290                                              (string->symbol
     291                                               (string-downcase maybe-severity)))
     292                     error-class:        (and sqlstate (string-take sqlstate 2))
     293                     error-code:         sqlstate
     294                     message-detail:     (get-error-field PG_DIAG_MESSAGE_DETAIL)
     295                     message-hint:       (get-error-field PG_DIAG_MESSAGE_HINT)
     296                     statement-position: (and maybe-statement-position
     297                                              (string->number
     298                                               maybe-statement-position))
     299                     context:            (get-error-field PG_DIAG_CONTEXT)
     300                     source-file:        (get-error-field PG_DIAG_SOURCE_FILE)
     301                     source-line:        (get-error-field PG_DIAG_SOURCE_LINE)
     302                     source-function:    (get-error-field PG_DIAG_SOURCE_FUNCTION))))
     303              ;; Read out all remaining results (including the current one).
     304              ;; TODO: Is this really needed? libpq does it (in pqExecFinish),
     305              ;; but ostensibly only to concatenate the error messages for
     306              ;; each query.  OTOH, maybe we want to do that, too.
     307              (let clean-results! ((result result))
     308                (when result
     309                  (PQclear result)
     310                  (clean-results! (PQgetResult (pg-connection-ptr conn)))))
     311              (signal condition)))
     312           (else
     313            (let ((result-obj (make-pg-result result)))
     314              (set-finalizer! result-obj clear-result)
     315              (loop (cons result-obj results)))))
    293316          (reverse! results)))))
     317
     318;; TODO: Ensure that no two queries can be issued at the same time! (thread lock)
     319;; This is needed because there's always only one "active" query.
     320(define (exec-query conn query)
     321  (if (PQsendQuery (pg-connection-ptr conn) query)
     322      (collect-results conn)
     323      (postgresql-error 'exec-query!
     324                        (conc "Unable to send query to server. "
     325                              (PQerrorMessage (pg-connection-ptr conn)))
     326                        conn query)))
     327
     328;;;;;;;;;;;;;;;;;;;;;;
     329;; Value handling
     330;;;;;;;;;;;;;;;;;;;;;;
     331
     332(define (escape-string conn str)
     333  (define %escape-string-conn
     334    (foreign-lambda* c-string* ((pointer conn) (c-string from) (int fromlen))
     335                     "int err = 0; char *to;"
     336                     "to = malloc(sizeof(char) * (fromlen * 2 + 1));"
     337                     "PQescapeStringConn(conn, to, from, fromlen, &err);"
     338                     "if (err) {"
     339                     "  free(to);"
     340                     "  C_return(NULL);"
     341                     "}"
     342                     "C_return(to);"
     343                     ))
     344  (or (%escape-string-conn conn str (string-length str))
     345      (postgresql-error 'escape-string
     346                        (conc "String escaping failed. "
     347                              (PQerrorMessage conn)))))
     348
     349;;;;;;;;;;;;;;;;;;;;;;;;;;;
     350;;;; Old stuff to look at
     351;;;;;;;;;;;;;;;;;;;;;;;;;;;
    294352
    295353(define (make-value-parsers result nfields)
     
    309367        [seed-count (length seeds)])
    310368
    311     (map (lambda (result)
    312            (set-finalizer! result
    313                            (lambda (r)
    314                              (PQclear r))))
    315          results)
    316      
    317369    (let process-result ([results results]
    318370                         [seeds seeds])
     
    348400                (define (get-value row column)
    349401                  (if (PQgetisnull result row column)
    350                       pgsql-null-object
     402                      (sql-null)
    351403                      (let ([value (PQgetvalue result row column)]
    352404                            [value-length
     
    522574   connection))
    523575
    524 
    525 ;; Escape strings
    526 (define (escape-string conn str)
    527   (define %escape-string-conn
    528     (foreign-lambda* c-string* ((pointer conn) (c-string from) (int fromlen))
    529                      "int err = 0; char *to;"
    530                      "to = malloc(sizeof(char) * (fromlen * 2 + 1));"
    531                      "PQescapeStringConn(conn, to, from, fromlen, &err);"
    532                      "if (err) {"
    533                      "  free(to);"
    534                      "  C_return(NULL);"
    535                      "}"
    536                      "C_return(to);"
    537                      ))
    538   (or (%escape-string-conn conn str (string-length str))
    539       (postgresql-error 'escape-string
    540                         (conc "String escaping failed. "
    541                               (PQerrorMessage conn)))))
    542 
    543 
    544576;;; query with params stuff
    545577
  • release/4/postgresql/trunk/tests/run.scm

    r14669 r14678  
    11(use test postgresql)
     2
     3;; These tests assume that the current UNIX user has access to a database
     4;; named 'test'.  The tests will fail otherwise.
    25
    36(test-group "connection management"
     
    2730(define conn (connect '((dbname . test))))
    2831
     32(test-group "low-level query support"
     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 'hi'; SELECT TRUE")))
     39  (test "Correct row count"
     40        2
     41        (result-rows (car (exec-query conn "SELECT 1 UNION SELECT 2"))))
     42  (test "Correct column count"
     43        4
     44        (result-columns (car (exec-query conn "SELECT 1, 2, 3, 4"))))
     45  (test "Correct column name"
     46        "one"
     47        (result-column-name
     48         (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))
     53  ;; Maybe add a few tests here for case folding/noncase folding variants?
     54  ;; Perhaps result-column-index-ci vs result-column-index?  That would be
     55  ;; misleading though, since result-column-index-ci isn't really ci,
     56  ;; it will not match columns that are explicitly uppercased in the query.
     57  (test "Correct column index"
     58        0
     59        (result-column-index
     60         (car (exec-query conn "SELECT 1 AS one, 2 AS two")) "one"))
     61  (test "False for nonexistant column name"
     62        #f
     63        (result-column-index
     64         (car (exec-query conn "SELECT 1 AS one, 2 AS two")) "foo")))
Note: See TracChangeset for help on using the changeset viewer.