Changeset 14669 in project


Ignore:
Timestamp:
05/16/09 22:59:29 (11 years ago)
Author:
sjamaan
Message:

Bring back to life the connect/disconnect/reset-connection procedures, and add tests for them
The rest is still severely fucked

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

Legend:

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

    r14635 r14669  
    2020
    2121(module postgresql
    22  (pg:connect pg:reset pg:close pg:query-fold-left pg:query-for-each
    23   pg:query-tuples pg:sql-null-object? pg:connection? pg:escape-string
    24   pg:sql-null-object
    25   pg:named-tuples)
     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)
    2629
    2730(import chicken scheme foreign)
     
    5154(define-foreign-type pgconn* c-pointer)
    5255
    53 (define pgsql-connection->fd (foreign-lambda int PQsocket pgconn*))
    54 
    5556(define PQconnectStart (foreign-lambda pgconn* PQconnectStart (const c-string)))
    5657(define PQconnectPoll (foreign-lambda pg-polling-status PQconnectPoll pgconn*))
     
    6566
    6667;; TODO: Add define-foreign-type for creating the lists of oids/value strings
    67 (define PQsendQueryParams
     68#;(define PQsendQueryParams
    6869  (foreign-lambda int PQsendQueryParams
    6970                  ;; conn  command          nParams
     
    118119(define-foreign-int PG_DIAG_SOURCE_FUNCTION)
    119120
    120 
    121 (define (pg:error loc message . args)
     121(define (postgresql-error loc message . args)
    122122  (signal (make-pg-condition loc message args: args)))
    123123
     
    139139     'source-function source-function)))
    140140
    141 (define-record pg:connection ptr)
     141(define-record pg-connection ptr)
     142(define connection? pg-connection?)
    142143
    143144(define-record sql-null-object)
    144 (define pg:sql-null-object (make-sql-null-object))
    145 (define (pg:sql-null-object? x)
    146   (eq? x pg:sql-null-object))
    147 
    148 (define-syntax push!
    149   (syntax-rules ()
    150     ((_ value place)
    151      (set! place (cons value place)))))
    152 
    153 (define (pg:poll conn-ptr poll-function)
    154   (let ([conn-fd (pgsql-connection->fd conn-ptr)])
    155     (let loop ([result (poll-function conn-ptr)])
    156       (cond [(= result PGRES_POLLING_OK)
    157              conn-ptr]
    158             [(= result PGRES_POLLING_FAILED)
    159              (let ((error-message (PQerrorMessage conn-ptr)))
    160                (PQfinish conn-ptr)
    161                (pg:error 'pg:connect (conc "Polling Postgres database failed. "
    162                                            error-message)))]
    163             [(member result (list PGRES_POLLING_WRITING PGRES_POLLING_READING))
     145(define pgsql-null-object (make-sql-null-object))
     146(define (sql-null-object? x)
     147  (eq? x pgsql-null-object))
     148
     149(define (pgsql-connection->fd conn)
     150  ((foreign-lambda int PQsocket pgconn*) (pg-connection-ptr conn)))
     151
     152;; TODO: Add timeout code
     153(define (wait-for-connection! conn poll-function)
     154  (let ((conn-fd (pgsql-connection->fd conn))
     155        (conn-ptr (pg-connection-ptr conn)))
     156    (let loop ((result (poll-function conn-ptr)))
     157      (cond ((= result PGRES_POLLING_OK) (void))
     158            ((= result PGRES_POLLING_FAILED)
     159             (let ((error-message (PQerrorMessage conn-ptr)))
     160               (disconnect conn)
     161               (postgresql-error 'connect
     162                                (conc "Polling Postgres database failed. "
     163                                       error-message))))
     164            ((member result (list PGRES_POLLING_WRITING PGRES_POLLING_READING))
    164165             (thread-wait-for-i/o! conn-fd (if (= PGRES_POLLING_READING result)
    165166                                               #:output
    166167                                               #:input))
    167              (loop (poll-function conn-ptr))]))))
     168             (loop (poll-function conn-ptr)))
     169            (else
     170             (postgresql-error 'connect (conc "Unknown status code!")))))))
    168171
    169172(define (alist->connection-spec alist)
    170173  (string-join
    171174   (map (lambda (subspec)
    172           (sprintf "~A = '~A'" (car subspec)
     175          (sprintf "~A='~A'"
     176                   (car subspec) ;; this had better not contain [ =\']
    173177                   (string-translate* (->string (cdr subspec))
    174                                       '(("\\" . "\\\\")
    175                                         ("'" . "\\'")))))
     178                                      '(("\\" . "\\\\") ("'" . "\\'")))))
    176179        alist)))
    177180
    178 (define pg:connect
    179   (let ([types-mapped? #f])
    180     (lambda (connection-spec)
    181       ;; This function will yield when connections aren't ready as long as
    182       ;; it doesn't have to do (blocking) DNS-lookup to connect to the
    183       ;; database:
    184       (define (pg-connect-nonblocking connection-spec)
    185         (let ([conn-ptr (PQconnectStart connection-spec)])
    186           (cond
    187            [(not conn-ptr)
    188             (pg:error 'pg:connect
    189                       "Unable to allocate a Postgres connection structure."
    190                       connection-spec)]
    191            [(= (foreign-value "CONNECTION_BAD" int) (PQstatus conn-ptr))
    192             (let ((error-message (PQerrorMessage conn-ptr)))
    193              (PQfinish conn-ptr)
    194              (pg:error 'pg:connect (conc "Connection to Postgres database failed: " error-message)
    195                        connection-spec))]
    196            [else
    197             (pg:poll conn-ptr PQconnectPoll)])))
    198      
    199       (let* ((connspec (if (string? connection-spec)
    200                            connection-spec
    201                            (alist->connection-spec connection-spec)))
    202              (conn (make-pg:connection (pg-connect-nonblocking connspec))))
    203         (set-finalizer! conn pg:close)
    204         ;; Retrieve type-information from PostgreSQL metadata for use by the
    205         ;; various value-parsers.
    206         (unless types-mapped?
    207           (fixup-types conn)
    208           (set! types-mapped? #t))
    209         conn))))
    210 
    211 (define (pg:reset connection)
    212   (let ([conn-ptr (pg:connection-ptr connection)])
     181(define (connect connection-spec)
     182  (let* ((connection-spec (if (string? connection-spec)
     183                              connection-spec
     184                              (alist->connection-spec connection-spec)))
     185         (conn-ptr (PQconnectStart connection-spec)))
     186    (cond
     187     ((not conn-ptr)
     188      (postgresql-error 'connect
     189                        "Unable to allocate a Postgres connection structure."
     190                        connection-spec))
     191     ((= (foreign-value "CONNECTION_BAD" int) (PQstatus conn-ptr))
     192      (let ((error-message (PQerrorMessage conn-ptr)))
     193        (PQfinish conn-ptr)
     194        (postgresql-error 'connect
     195                          (conc "Connection to Postgres database failed: "
     196                                error-message)
     197                          connection-spec)))
     198     (else
     199      (let ((conn (make-pg-connection conn-ptr)))
     200        (wait-for-connection! conn PQconnectPoll)
     201        (set-finalizer! conn disconnect)
     202        ;; Retrieve type-information from PostgreSQL metadata for use by
     203        ;; the various value-parsers.
     204        (fixup-types conn)
     205        conn)))))
     206
     207(define (reset-connection connection)
     208  (let ((conn-ptr (pg-connection-ptr connection)))
    213209    (if (PQresetStart conn-ptr)
    214         (begin (pg:poll conn-ptr PQresetPoll)
    215                (void))
     210        (wait-for-connection! connection PQresetPoll)
    216211        (let ((error-message (PQerrorMessage conn-ptr)))
    217           (pg:error 'pg:reset (conc "Reset of connection failed " error-message)
    218                     connection)))))
    219 
    220 (define (pg:close connection)
    221   (let ([conn-ptr (pg:connection-ptr connection)])
    222     (when conn-ptr
    223       (PQfinish conn-ptr)
    224       (pg:connection-ptr-set! connection #f)))
     212          (disconnect connection)
     213          (postgresql-error 'reset-connection
     214                            (conc "Reset of connection failed " error-message)
     215                            connection)))))
     216
     217(define (disconnect connection)
     218  (and-let* ((conn-ptr (pg-connection-ptr connection)))
     219    (PQfinish conn-ptr)
     220    (pg-connection-ptr-set! connection #f))
    225221  (void))
    226222
    227 ;; XXX: Should probably provide escaping function somewhere.
    228 
    229223;; Buffer all available input, yielding if nothing is available:
    230 (define (buffer-available-input! conn-ptr query)
    231   (let ([query-reply (if (pair? query)
    232                          (pq-send-query-params conn-ptr query)
     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)
    233228                         (PQsendQuery conn-ptr query))])
    234229
    235230    (if (zero? query-reply)
    236         (pg:error 'buffer-available-input!
    237                   (sprintf "PQsendQuery: ~A"
    238                            (string-trim-right (PQerrorMessage conn-ptr)))
    239                   query conn-ptr))
     231        (postgresql-error 'buffer-available-input!
     232                          (sprintf "PQsendQuery: ~A"
     233                                   (string-trim-right (PQerrorMessage conn-ptr)))
     234                          query conn))
    240235 
    241     (let ([conn-fd (pgsql-connection->fd conn-ptr)])
     236    (let ([conn-fd (pgsql-connection->fd conn)])
    242237      (let loop ()
    243238        (if (PQconsumeInput conn-ptr)
     
    245240              (thread-wait-for-i/o! conn-fd #:input)
    246241              (loop))
    247             (pg:error 'buffer-available-input!
    248                       (sprintf "PQconsumeInput: ~A"
    249                                (string-trim-right (PQerrorMessage conn-ptr)))
    250                       conn-ptr)))
     242            (postgresql-error 'buffer-available-input!
     243                              (sprintf "PQconsumeInput: ~A"
     244                                       (string-trim-right
     245                                        (PQerrorMessage conn-ptr)))
     246                              conn-ptr)))
    251247      (void))))
    252248
    253249;; Collect the result pointers from the last query:
    254 (define (collect-results conn-ptr)
    255   (define (cleanup-results! conn-ptr)
     250(define (collect-results conn)
     251  (define (cleanup-results! conn)
    256252    (let loop ()
    257       (let ([result (PQgetResult conn-ptr)])
     253      (let ([result (PQgetResult (pg-connection-ptr conn))])
    258254        (when result
    259255          (PQclear result)
     
    262258
    263259  (let loop ([results (list)])
    264     (let ([result (PQgetResult conn-ptr)])
     260    (let* ([conn-ptr (pg-connection-ptr conn)]
     261           [result (PQgetResult conn-ptr)])
    265262      (if result
    266263          (cond
     
    276273                     'collect-results
    277274                     (sprintf "PQgetResult: ~A" msg)
    278                      args:               (list conn-ptr)
     275                     args:               (list conn)
    279276                     severity:           (and maybe-severity
    280277                                              (string->symbol (string-downcase maybe-severity)))
    281                      error-class:         (and sqlstate (sqlstate->error-class sqlstate))
    282                      error-code:         (and sqlstate (sqlstate->error-code sqlstate))
     278                     error-class:         (and sqlstate (string-take sqlstate 2))
     279                     error-code:          sqlstate
    283280                     message-detail:     (get-error-field PG_DIAG_MESSAGE_DETAIL)
    284281                     message-hint:       (get-error-field PG_DIAG_MESSAGE_HINT)
     
    290287                     source-function:    (get-error-field PG_DIAG_SOURCE_FUNCTION))])
    291288              (PQclear result)
    292               (cleanup-results! conn-ptr)
     289              (cleanup-results! conn)
    293290              (signal condition))]
    294291           [else
     
    304301                                 (lambda () text-parser)))))
    305302
    306 (define pg:named-tuples (make-parameter #f))
    307 
    308 (define (pg:query-fold-left query connection fold-function . seeds)
    309   (let ([conn-ptr (pg:connection-ptr connection)])
    310 
    311     (buffer-available-input! conn-ptr query)
    312 
    313     (let ([results (collect-results conn-ptr)]
    314           [seed-count (length seeds)])
    315 
    316       (map (lambda (result)
    317              (set-finalizer! result
    318                              (lambda (r)
    319                                (PQclear r))))
    320            results)
     303(define named-tuples (make-parameter #f))
     304
     305(define (query-fold-left query conn fold-function . seeds)
     306  #;(buffer-available-input! conn query)
     307
     308  (let ([results (collect-results conn)]
     309        [seed-count (length seeds)])
     310
     311    (map (lambda (result)
     312           (set-finalizer! result
     313                           (lambda (r)
     314                             (PQclear r))))
     315         results)
    321316     
    322       (let process-result ([results results]
    323                            [seeds seeds])
    324 
    325         (if (null? results)
    326             (apply values seeds)
    327             (let* ([result (car results)]
    328                    [result-status (PQresultStatus result)])
     317    (let process-result ([results results]
     318                         [seeds seeds])
     319
     320      (if (null? results)
     321          (apply values seeds)
     322          (let* ([result (car results)]
     323                 [result-status (PQresultStatus result)])
    329324             
    330               (cond
    331                ;; No tuples returned.  Instead of tuple, provide the
    332                ;; number of tuples affected by the query:
    333                [(= result-status PGRES_COMMAND_OK)
    334                 (let ([ntuples (string->number (PQcmdTuples result))])
    335                   (receive (proceed? . new-seeds)
    336                       (apply fold-function ntuples seeds)
    337                     (cond [(= (length new-seeds) seed-count)
    338                            (if proceed?
    339                                (process-result (cdr results) new-seeds)
    340                                (apply values new-seeds))]
    341                           [else
    342                            (error "Wrong seed count"
    343                                   `(expected ,seed-count)
    344                                   `(got ,(length new-seeds)))])))]
    345 
    346                ;; 0 or more tuples were returned.
    347                [(= result-status PGRES_TUPLES_OK)
    348                 (let* ([nfields (PQnfields result)]
    349                        [ntuples (PQntuples result)]
    350                        [value-parsers (make-value-parsers
    351                                        result nfields)])
     325            (cond
     326             ;; No tuples returned.  Instead of tuple, provide the
     327             ;; number of tuples affected by the query:
     328             [(= result-status PGRES_COMMAND_OK)
     329              (let ([ntuples (string->number (PQcmdTuples result))])
     330                (receive (proceed? . new-seeds)
     331                  (apply fold-function ntuples seeds)
     332                  (cond [(= (length new-seeds) seed-count)
     333                         (if proceed?
     334                             (process-result (cdr results) new-seeds)
     335                             (apply values new-seeds))]
     336                        [else
     337                         (error "Wrong seed count"
     338                                `(expected ,seed-count)
     339                                `(got ,(length new-seeds)))])))]
     340
     341             ;; 0 or more tuples were returned.
     342             [(= result-status PGRES_TUPLES_OK)
     343              (let* ([nfields (PQnfields result)]
     344                     [ntuples (PQntuples result)]
     345                     [value-parsers (make-value-parsers
     346                                     result nfields)])
    352347             
    353                   (define (get-value row column)
    354                     (if (PQgetisnull result row column)
    355                         pg:sql-null-object
    356                         (let ([value (PQgetvalue result row column)]
    357                               [value-length
    358                                (PQgetlength result row column)])
    359                           ((vector-ref value-parsers column)
    360                            value value-length))))
     348                (define (get-value row column)
     349                  (if (PQgetisnull result row column)
     350                      pgsql-null-object
     351                      (let ([value (PQgetvalue result row column)]
     352                            [value-length
     353                             (PQgetlength result row column)])
     354                        ((vector-ref value-parsers column)
     355                         value value-length))))
    361356             
    362                   (let process-row ([row 0]
    363                                     [seeds seeds])
    364 
    365                     (if (= row ntuples)
    366                         (process-result (cdr results) seeds)
    367                         (let ([tuple (make-vector nfields)]
    368                                [get-value* (if (pg:named-tuples)
    369                                                (lambda (row col)
    370                                                   (cons (string->symbol (PQfname result col))
    371                                                         (get-value row col)))
    372                                                get-value)])
     357                (let process-row ([row 0]
     358                                  [seeds seeds])
     359
     360                  (if (= row ntuples)
     361                      (process-result (cdr results) seeds)
     362                      (let ([tuple (make-vector nfields)]
     363                            [get-value* (if (named-tuples)
     364                                            (lambda (row col)
     365                                              (cons (string->symbol (PQfname result col))
     366                                                    (get-value row col)))
     367                                            get-value)])
    373368                           
    374                           (do ([col 0 (+ col 1)])
    375                               ([= col nfields])
    376                                 (vector-set! tuple col (get-value* row col)))
     369                        (do ([col 0 (+ col 1)])
     370                            ([= col nfields])
     371                          (vector-set! tuple col (get-value* row col)))
    377372                         
    378                           (receive (proceed? . new-seeds)
    379                               (apply fold-function tuple seeds)
    380                             (cond
    381                              [(= (length new-seeds) seed-count)
    382                               (if proceed?
    383                                   (process-row (+ row 1) new-seeds)
    384                                   (apply values new-seeds))]
    385                              [else
    386                               (error "Wrong seed count"
    387                                      `(expected ,seed-count)
    388                                      `(got ,(length new-seeds)))]))))))]
    389 
    390                [(= result-status PGRES_EMPTY_QUERY)
    391                 (pg:error 'pg-query-fold-left "Empty query")]
    392 
    393                [else
    394                 (pg:error 'pg-query-fold-left
    395                           "Unsupported result type:" result-status)])))))))
    396 
    397 (define (pg:query-for-each proc query connection)
     373                        (receive (proceed? . new-seeds)
     374                          (apply fold-function tuple seeds)
     375                          (cond
     376                           [(= (length new-seeds) seed-count)
     377                            (if proceed?
     378                                (process-row (+ row 1) new-seeds)
     379                                (apply values new-seeds))]
     380                           [else
     381                            (error "Wrong seed count"
     382                                   `(expected ,seed-count)
     383                                   `(got ,(length new-seeds)))]))))))]
     384
     385             [(= result-status PGRES_EMPTY_QUERY)
     386              (postgresql-error 'query-fold-left "Empty query")]
     387
     388             [else
     389              (postgresql-error 'query-fold-left
     390                                "Unsupported result type:"
     391                                result-status)]))))))
     392
     393(define (query-for-each proc query connection)
    398394  (receive ()
    399       (pg:query-fold-left query connection
     395      (query-fold-left query connection
    400396                          (lambda (tuple)
    401397                            (proc tuple)
     
    403399    (void)))
    404400
    405 (define (pg:query-tuples query connection)
     401(define (query-tuples query connection)
    406402  (reverse!
    407    (pg:query-fold-left query connection
     403   (query-fold-left query connection
    408404                       (lambda (tuple tuples)
    409405                         (values #t (cons tuple tuples)))
     
    433429
    434430(define (parse-format-string s)
    435   (do ([i 0 (+ i 1)]
    436        [ranges (list)]
    437        [cur-range (list)]
    438        [len (string-length s)])
    439       ([= i len]
    440        (when (not (null? cur-range))
    441          (push! (cons (- i (length cur-range)) i)
    442                 ranges))
    443        (reverse! ranges))
    444     (let ([char (string-ref s i)])
    445       (cond ([and (or (null? cur-range)
    446                       (char=? char (car cur-range)))
    447                   (char-alphabetic? char)]
    448              (push! char cur-range))
    449             ([and (not (null? cur-range))
    450                   (not (char=? char (car cur-range)))]
    451              (push! (cons (- i (length cur-range)) i)
    452                     ranges)
    453              (set! cur-range
    454                    (if (char-alphabetic? char)
    455                        (list char)
    456                        (list))))))))
     431  (let-syntax ((push! (syntax-rules ()
     432                        ((_ value place)
     433                         (set! place (cons value place))))))
     434    (do ([i 0 (+ i 1)]
     435         [ranges (list)]
     436         [cur-range (list)]
     437         [len (string-length s)])
     438        ([= i len]
     439         (when (not (null? cur-range))
     440           (push! (cons (- i (length cur-range)) i)
     441                  ranges))
     442         (reverse! ranges))
     443      (let ([char (string-ref s i)])
     444        (cond ([and (or (null? cur-range)
     445                        (char=? char (car cur-range)))
     446                    (char-alphabetic? char)]
     447               (push! char cur-range))
     448              ([and (not (null? cur-range))
     449                    (not (char=? char (car cur-range)))]
     450               (push! (cons (- i (length cur-range)) i)
     451                      ranges)
     452               (set! cur-range
     453                     (if (char-alphabetic? char)
     454                         (list char)
     455                         (list)))))))))
    457456
    458457(define-syntax define-time-parser
     
    485484    (if num
    486485        num
    487         (pg:error 'numeric-parser "Unable to parse the number" num-string))))
     486        (postgresql-error 'numeric-parser
     487                          "Unable to parse the number" num-string))))
    488488
    489489(define type-map
     
    512512;; Retrieve type-oids from PostgreSQL:
    513513(define (fixup-types connection)
    514   (pg:query-for-each
     514  (query-for-each
    515515   (lambda (parameters)
    516516     (let* ([oid (string->number (vector-ref parameters 0))]
     
    524524
    525525;; Escape strings
    526 (define %pg:escape-string-conn
    527   (foreign-lambda* c-string* ((pointer conn) (c-string from) (int fromlen))
    528                    "int err = 0; char *to;"
    529                    "to = malloc(sizeof(char) * (fromlen * 2 + 1));"
    530                    "PQescapeStringConn(conn, to, from, fromlen, &err);"
    531                    "if (err) {"
    532                    "  free(to);"
    533                    "  C_return(NULL);"
    534                    "}"
    535                    "C_return(to);"
    536                    ))
    537 
    538 (define (pg:escape-string conn str)
    539   (or (%pg:escape-string-conn conn str (string-length str))
    540       (pg:error 'pg:connect
    541                 (conc "String escaping failed. " (PQerrorMessage conn)))))
    542 
    543 
    544 (define sqlstate->error-class
    545   (let ((dict '(("00" . successful-completion)
    546                 ("01" . warning)
    547                 ("02" . no-data)
    548                 ("03" . sql-statement-not-yet-complete)
    549                 ("08" . connection-exception)
    550                 ("09" . triggered-action-exception)
    551                 ("0A" . feature-not-supported)
    552                 ("0B" . invalid-transaction-initiation)
    553                 ("0F" . locator-exception)
    554                 ("0L" . invalid-grantor)
    555                 ("0P" . invalid-role-specification)
    556                 ("21" . cardinality-violation)
    557                 ("22" . data-exception)
    558                 ("23" . integrity-constraint-violation)
    559                 ("24" . invalid-cursor-state)
    560                 ("25" . invalid-transaction-state)
    561                 ("26" . invalid-sql-statement-name)
    562                 ("27" . triggered-data-change-violation)
    563                 ("28" . invalid-authorization-specification)
    564                 ("2B" . dependent-privilege-descriptors-still-exist)
    565                 ("2D" . invalid-transaction-termination)
    566                 ("2F" . sql-routine-exception)
    567                 ("34" . invalid-cursor-name)
    568                 ("38" . external-routine-exception)
    569                 ("39" . external-routine-invocation-exception)
    570                 ("3D" . invalid-catalog-name)
    571                 ("3F" . invalid-schema-name)
    572                 ("40" . transaction-rollback)
    573                 ("42" . syntax-error-or-access-rule-violation)
    574                 ("44" . with-check-option-violation)
    575                 ("53" . insufficient-resources)
    576                 ("54" . program-limit-exceeded)
    577                 ("55" . object-not-in-prerequisite-state)
    578                 ("57" . operator-intervention)
    579                 ("58" . system-error)
    580                 ("f0" . configuration-file-error)
    581                 ("XX" . internal-error))))
    582     (lambda (s)
    583       (cdr (assoc (string-take s 2) dict)))))
    584 
    585 
    586 
    587 (define sqlstate->error-code
    588   (let ((dict '(("00000" . successful-completion)
    589                 ("01000" . warning)
    590                 ("0100C" . warning-dynamic-result-sets-returned)
    591                 ("01008" . warning-implicit-zero-bit-padding)
    592                 ("01003" . warning-null-value-eliminated-in-set-function)
    593                 ("01004" . warning-string-data-right-truncation)
    594                 ("02000" . no-data)
    595                 ("02001" . no-additional-dynamic-result-sets-returned)
    596                 ("03000" . sql-statement-not-yet-complete)
    597                 ("08000" . connection-exception)
    598                 ("08003" . connection-does-not-exist)
    599                 ("08006" . connection-failure)
    600                 ("08001" . sqlclient-unable-to-establish-sqlconnection)
    601                 ("08004" . sqlserver-rejected-establishment-of-sqlconnection)
    602                 ("08007" . transaction-resolution-unknown)
    603                 ("08P01" . protocol-violation)
    604                 ("09000" . triggered-action-exception)
    605                 ("0A000" . feature-not-supported)
    606                 ("0B000" . invalid-transaction-initiation)
    607                 ("0F000" . locator-exception)
    608                 ("0F001" . invalid-specification)
    609                 ("0L000" . invalid-grantor)
    610                 ("0LP01" . invalid-grant-operation)
    611                 ("0P000" . invalid-role-specification)
    612                 ("21000" . cardinality-violation)
    613                 ("22000" . data-exception)
    614                 ("2202E" . array-element-error)
    615                 ("22021" . character-not-in-repertoire)
    616                 ("22008" . datetime-field-overflow)
    617                 ("22012" . division-by-zero)
    618                 ("22005" . error-in-assignment)
    619                 ("2200B" . escape-character-conflict)
    620                 ("22022" . indicator-overflow)
    621                 ("22015" . interval-field-overflow)
    622                 ("22018" . invalid-character-value-for-cast)
    623                 ("22007" . invalid-datetime-format)
    624                 ("22019" . invalid-escape-character)
    625                 ("2200D" . invalid-escape-octet)
    626                 ("22025" . invalid-escape-sequence)
    627                 ("22010" . invalid-indicator-parameter-value)
    628                 ("22020" . invalid-limit-value)
    629                 ("22023" . invalid-parameter-value)
    630                 ("2201B" . invalid-regular-expression)
    631                 ("22009" . invalid-time-zone-displacement-value)
    632                 ("2200C" . invalid-use-of-escape-character)
    633                 ("2200G" . most-specific-type-mismatch)
    634                 ("22004" . null-value-not-allowed)
    635                 ("22002" . null-value-no-indicator-parameter)
    636                 ("22003" . numeric-value-out-of-range)
    637                 ("22026" . string-data-length-mismatch)
    638                 ("22001" . string-data-right-truncation)
    639                 ("22011" . substring-error)
    640                 ("22027" . trim-error)
    641                 ("22024" . unterminated-c-string)
    642                 ("2200F" . zero-length-character-string)
    643                 ("22P01" . floating-point-exception)
    644                 ("22P02" . invalid-text-representation)
    645                 ("22P03" . invalid-binary-representation)
    646                 ("22P04" . bad-copy-file-format)
    647                 ("22P05" . untranslatable-character)
    648                 ("23000" . integrity-constraint-violation)
    649                 ("23001" . restrict-violation)
    650                 ("23502" . not-null-violation)
    651                 ("23503" . foreign-key-violation)
    652                 ("23505" . unique-violation)
    653                 ("23514" . check-violation)
    654                 ("24000" . invalid-cursor-state)
    655                 ("25000" . invalid-transaction-state)
    656                 ("25001" . active-sql-transaction)
    657                 ("25002" . branch-transaction-already-active)
    658                 ("25008" . held-cursor-requires-same-isolation-level)
    659                 ("25003" . inappropriate-access-mode-for-branch-transaction)
    660                 ("25004" . inappropriate-isolation-level-for-branch-transaction)
    661                 ("25005" . no-active-sql-transaction-for-branch-transaction)
    662                 ("25006" . read-only-sql-transaction)
    663                 ("25007" . schema-and-data-statement-mixing-not-supported)
    664                 ("25P01" . no-active-sql-transaction)
    665                 ("25P02" . in-failed-sql-transaction)
    666                 ("26000" . invalid-sql-statement-name)
    667                 ("27000" . triggered-data-change-violation)
    668                 ("28000" . invalid-authorization-specification)
    669                 ("2B000" . dependent-privilege-descriptors-still-exist)
    670                 ("2BP01" . dependent-objects-still-exist)
    671                 ("2D000" . invalid-transaction-termination)
    672                 ("2F000" . sql-routine-exception)
    673                 ("2F005" . function-executed-no-return-statement)
    674                 ("2F002" . modifying-sql-data-not-permitted)
    675                 ("2F003" . prohibited-sql-statement-attempted)
    676                 ("2F004" . reading-sql-data-not-permitted)
    677                 ("34000" . invalid-cursor-name)
    678                 ("38000" . external-routine-exception)
    679                 ("38001" . containing-sql-not-permitted)
    680                 ("38002" . modifying-sql-data-not-permitted)
    681                 ("38003" . prohibited-sql-statement-attempted)
    682                 ("38004" . reading-sql-data-not-permitted)
    683                 ("39000" . external-routine-invocation-exception)
    684                 ("39001" . invalid-sqlstate-returned)
    685                 ("39004" . null-value-not-allowed)
    686                 ("39P01" . trigger-protocol-violated)
    687                 ("39P02" . srf-protocol-violated)
    688                 ("3D000" . invalid-catalog-name)
    689                 ("3F000" . invalid-schema-name)
    690                 ("40000" . transaction-rollback)
    691                 ("40002" . integrity-constraint-violation)
    692                 ("40001" . serialization-failure)
    693                 ("40003" . statement-completion-unknown)
    694                 ("40P01" . deadlock-detected)
    695                 ("42000" . syntax-error-or-access-rule-violation)
    696                 ("42601" . syntax-error)
    697                 ("42501" . insufficient-privilege)
    698                 ("42846" . cannot-coerce)
    699                 ("42803" . grouping-error)
    700                 ("42830" . invalid-foreign-key)
    701                 ("42602" . invalid-name)
    702                 ("42622" . name-too-long)
    703                 ("42939" . reserved-name)
    704                 ("42804" . datatype-mismatch)
    705                 ("42P18" . indeterminate-datatype)
    706                 ("42809" . wrong-object-type)
    707                 ("42703" . undefined-column)
    708                 ("42883" . undefined-function)
    709                 ("42P01" . undefined-table)
    710                 ("42P02" . undefined-parameter)
    711                 ("42704" . undefined-object)
    712                 ("42701" . duplicate-column)
    713                 ("42P03" . duplicate-cursor)
    714                 ("42P04" . duplicate-database)
    715                 ("42723" . duplicate-function)
    716                 ("42P05" . duplicate-pstatement)
    717                 ("42P06" . duplicate-schema)
    718                 ("42P07" . duplicate-table)
    719                 ("42712" . duplicate-alias)
    720                 ("42710" . duplicate-object)
    721                 ("42702" . ambiguous-column)
    722                 ("42725" . ambiguous-function)
    723                 ("42P08" . ambiguous-parameter)
    724                 ("42P09" . ambiguous-alias)
    725                 ("42P10" . invalid-column-reference)
    726                 ("42611" . invalid-column-definition)
    727                 ("42P11" . invalid-cursor-definition)
    728                 ("42P12" . invalid-database-definition)
    729                 ("42P13" . invalid-function-definition)
    730                 ("42P14" . invalid-pstatement-definition)
    731                 ("42P15" . invalid-schema-definition)
    732                 ("42P16" . invalid-table-definition)
    733                 ("42P17" . invalid-object-definition)
    734                 ("44000" . with-check-option-violation)
    735                 ("53000" . insufficient-resources)
    736                 ("53100" . disk-full)
    737                 ("53200" . out-of-memory)
    738                 ("53300" . too-many-connections)
    739                 ("54000" . program-limit-exceeded)
    740                 ("54001" . statement-too-complex)
    741                 ("54011" . too-many-columns)
    742                 ("54023" . too-many-arguments)
    743                 ("55000" . object-not-in-prerequisite-state)
    744                 ("55006" . object-in-use)
    745                 ("55P02" . cant-change-runtime-param)
    746                 ("57000" . operator-intervention)
    747                 ("57014" . query-canceled)
    748                 ("57P01" . admin-shutdown)
    749                 ("57P02" . crash-shutdown)
    750                 ("57P03" . cannot-connect-now)
    751                 ("58030" . io-error)
    752                 ("58P01" . undefined-file)
    753                 ("58P02" . duplicate-file)
    754                 ("F0000" . config-file-error)
    755                 ("F0001" . lock-file-exists)
    756                 ("XX000" . internal-error)
    757                 ("XX001" . data-corrupted)
    758                 ("XX002" . index-corrupted))))
    759          (lambda (s) (cdr (assoc s dict)))))
     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
    760543
    761544;;; query with params stuff
    762545
    763 (define (pq-send-query-params conn query-args #!key (format 'text))
     546#;(define (pq-send-query-params conn query-args #!key (format 'text))
    764547  ;; first attempt: all args will be text. I'll look at binary later.
    765548  (let* ((query (car query-args))
  • release/4/postgresql/trunk/postgresql.setup

    r14633 r14669  
    22;;; postgresql.setup -*- Scheme -*-
    33
    4 (run (csc -s -O2 -d0 postgresql.scm -j postgresql -C -I`pg_config --includedir` -L -L`pg_config --libdir` -lpq))
     4(run (csc -s -O2 -d0 postgresql.scm -j postgresql -C -I`pg_config --includedir` -L -L`pg_config --libdir` -L -R`pg_config --libdir` -lpq))
    55
    66(run (csc postgresql.import.scm -s -O2 -d0))
  • release/4/postgresql/trunk/tests/run.scm

    r14631 r14669  
    11(use test postgresql)
    22
     3(test-group "connection management"
     4  (test-assert "connect returns a connection"
     5               (let* ((conn (connect '((dbname . test))))
     6                      (isconn (connection? conn)))
     7                 (disconnect conn)
     8                 isconn))
     9  (test-error "cannot connect with invalid credentials"
     10              (connect '((dbname . does-not-exist)
     11                         (username . nobody))))
     12  (test-assert "reset-connection returns a connection"
     13               (let* ((conn (connect '((dbname . test))))
     14                      (isconn (connection? conn)))
     15                 (reset-connection conn)
     16                 (disconnect conn)
     17                 isconn))
     18  (test-error "disconnect invalidates the connection"
     19              (let ((conn (connect '((dbname . test)))))
     20                (disconnect conn)
     21                (reset-connection conn)))
     22  ;; It would be nice if we could test some more error cases here but
     23  ;; that's hard to do
     24  )
     25
     26;; From now on, just keep using the same connection
     27(define conn (connect '((dbname . test))))
     28
Note: See TracChangeset for help on using the changeset viewer.