Changeset 30251 in project


Ignore:
Timestamp:
12/29/13 20:17:16 (6 years ago)
Author:
sjamaan
Message:

postgresql: Fix formatting

File:
1 edited

Legend:

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

    r30250 r30251  
    133133   (lambda (e r c)
    134134     ;; cannot rename define-foreign-variable; it's a really special form
    135     `(define-foreign-variable ,(cadr e) int ,(conc "(int) " (cadr e))))))
     135     `(define-foreign-variable ,(cadr e) int ,(conc "(int) " (cadr e))))))
    136136
    137137(define-foreign-int PG_DIAG_SEVERITY)
     
    170170                           internal-query internal-position)
    171171  (make-composite-condition
    172     (make-property-condition
    173      'exn 'location loc 'message message 'arguments args)
    174     (make-property-condition
    175      'postgresql 'severity severity 'error-class error-class
    176      'error-code error-code
    177      'message-primary message-primary 'message-detail message-detail
    178      'message-hint message-hint 'statement-position statement-position
    179      'context context 'source-file source-file 'source-line source-line
    180      'internal-query internal-query 'internal-position internal-position
    181      'source-function source-function)
    182     (if (eq? subtype 'query)
    183         (make-property-condition
    184          'query 'severity severity 'error-class error-class
    185          'error-code error-code
    186          'message-primary message-primary 'message-detail message-detail
    187          'message-hint message-hint 'statement-position statement-position
    188          'context context 'source-file source-file 'source-line source-line
    189          'internal-query internal-query 'internal-position internal-position
    190          'source-function source-function)
    191         (if (condition? subtype) subtype (make-property-condition subtype)))))
     172   (make-property-condition
     173    'exn 'location loc 'message message 'arguments args)
     174   (make-property-condition
     175    'postgresql 'severity severity 'error-class error-class
     176    'error-code error-code
     177    'message-primary message-primary 'message-detail message-detail
     178    'message-hint message-hint 'statement-position statement-position
     179    'context context 'source-file source-file 'source-line source-line
     180    'internal-query internal-query 'internal-position internal-position
     181    'source-function source-function)
     182   (if (eq? subtype 'query)
     183       (make-property-condition
     184        'query 'severity severity 'error-class error-class
     185        'error-code error-code
     186        'message-primary message-primary 'message-detail message-detail
     187        'message-hint message-hint 'statement-position statement-position
     188        'context context 'source-file source-file 'source-line source-line
     189        'internal-query internal-query 'internal-position internal-position
     190        'source-function source-function)
     191       (if (condition? subtype) subtype (make-property-condition subtype)))))
    192192
    193193;;;;;;;;;;;;;;;;;;;;;;;;
     
    219219               (result (list)))
    220220      (if (null? chars)
    221           (car result) ; Should contain only one vector
     221          (car result)                ; Should contain only one vector
    222222          (case (car chars)
    223223            ((#\{) (receive (value rest-chars)
    224                      (loop (cdr chars) (list))
     224                       (loop (cdr chars) (list))
    225225                     (loop rest-chars (cons value result))))
    226226            ((#\}) (values (list->vector (reverse! result)) (cdr chars)))
     
    370370                            (else
    371371                             (sprintf "\"~A\""
    372                                       (string-translate*
    373                                        unparsed-value
    374                                        '(("\\" . "\\\\") ("\"" . "\\\""))))))))
     372                               (string-translate*
     373                                unparsed-value
     374                                '(("\\" . "\\\\") ("\"" . "\\\""))))))))
    375375          (loop (cons serialized result) (add1 pos) len)))))
    376376
     
    389389                            (else
    390390                             (sprintf "\"~A\""
    391                                       (string-translate*
    392                                        unparsed-value
    393                                        '(("\\" . "\\\\") ("\"" . "\\\""))))))))
     391                               (string-translate*
     392                                unparsed-value
     393                                '(("\\" . "\\\\") ("\"" . "\\\""))))))))
    394394          (loop (cons serialized result) (cdr items))))))
    395395
     
    416416         (and-let* ((procedure (assoc typname type-parsers)))
    417417           (hash-table-set! ht (string->number oid) (cdr procedure))))
    418        (query* conn (sprintf
    419                      "SELECT oid, typname FROM pg_type WHERE typname IN (~A)"
    420                      (in-list (length type-parsers)))
    421         (map car type-parsers) raw: #t)))))
     418       (query* conn
     419               (sprintf
     420                   "SELECT oid, typname FROM pg_type WHERE typname IN (~A)"
     421                 (in-list (length type-parsers)))
     422               (map car type-parsers) raw: #t)))))
    422423
    423424(define (update-type-unparsers! conn new-type-unparsers)
     
    428429;;;;;;;;;;;;;;;;;;;;
    429430
    430 (define-record
    431   pg-connection ptr
    432   type-parsers oid-parsers type-unparsers
    433   transaction-depth)
     431(define-record pg-connection
     432  ptr type-parsers oid-parsers type-unparsers transaction-depth)
    434433(define connection? pg-connection?)
    435434(define type-parsers pg-connection-type-parsers)
     
    461460
    462461(cond-expand
    463  ((not has-PQconnectdbParams)
    464   (define (alist->connection-spec alist)
    465     (string-join
    466      (map (lambda (subspec)
    467             (sprintf "~A='~A'"
    468                      (car subspec) ;; this had better not contain [ =\']
    469                      (string-translate* (->string (cdr subspec))
    470                                         '(("\\" . "\\\\") ("'" . "\\'")))))
    471           alist))))
    472  (else))
     462  ((not has-PQconnectdbParams)
     463   (define (alist->connection-spec alist)
     464     (string-join
     465      (map (lambda (subspec)
     466             (sprintf "~A='~A'"
     467               (car subspec) ;; this had better not contain [ =\']
     468               (string-translate* (->string (cdr subspec))
     469                                  '(("\\" . "\\\\") ("'" . "\\'")))))
     470           alist))))
     471  (else))
    473472
    474473(define (connect-start spec)
     
    476475      (PQconnectStart spec)
    477476      (cond-expand
    478        (has-PQconnectdbParams
    479         (let ((len (length spec)))
    480           ((foreign-lambda* pgconn* ((scheme-object cons) (scheme-pointer keybuf)
    481                                      (scheme-pointer valbuf) (int len))
    482              "const char **key = (const char **)keybuf;"
    483              "const char **val = (const char **)valbuf;"
    484              "int i;"
    485              "for (i=0; i < len; ++i,cons=C_u_i_cdr(cons)) {"
    486              "    C_word kvpair = C_u_i_car(cons);"
    487              "    key[i] = C_c_string(C_u_i_car(kvpair));"
    488              "    val[i] = C_c_string(C_u_i_cdr(kvpair));"
    489              "}"
    490              "key[len] = NULL;"
    491              "val[len] = NULL;"
    492              "C_return(PQconnectStartParams(key, val, 0));")
    493            (map (lambda (x) (cons (string-append (->string (car x)) "\x00")
    494                                   (string-append (->string (cdr x)) "\x00"))) spec)
    495            (make-blob (* (add1 len) (foreign-value "sizeof(char *)" int)))
    496            (make-blob (* (add1 len) (foreign-value "sizeof(char *)" int)))
    497            len)))
    498        (else (PQconnectStart (alist->connection-spec spec))))))
     477        (has-PQconnectdbParams
     478         (let ((len (length spec)))
     479           ((foreign-lambda* pgconn* ((scheme-object cons) (scheme-pointer keybuf)
     480                                      (scheme-pointer valbuf) (int len))
     481              "const char **key = (const char **)keybuf;"
     482              "const char **val = (const char **)valbuf;"
     483              "int i;"
     484              "for (i=0; i < len; ++i,cons=C_u_i_cdr(cons)) {"
     485              "    C_word kvpair = C_u_i_car(cons);"
     486              "    key[i] = C_c_string(C_u_i_car(kvpair));"
     487              "    val[i] = C_c_string(C_u_i_cdr(kvpair));"
     488              "}"
     489              "key[len] = NULL;"
     490              "val[len] = NULL;"
     491              "C_return(PQconnectStartParams(key, val, 0));")
     492            (map (lambda (x) (cons (string-append (->string (car x)) "\x00")
     493                                   (string-append (->string (cdr x)) "\x00"))) spec)
     494            (make-blob (* (add1 len) (foreign-value "sizeof(char *)" int)))
     495            (make-blob (* (add1 len) (foreign-value "sizeof(char *)" int)))
     496            len)))
     497        (else (PQconnectStart (alist->connection-spec spec))))))
    499498
    500499(define (connect #!optional (conn-spec '())
     
    518517        ;; We don't want libpq to piss in our stderr stream
    519518        ((foreign-lambda* void ((pgconn* conn))
    520           "PQsetNoticeReceiver(conn, nullNoticeReceiver, NULL);") conn-ptr)
     519           "PQsetNoticeReceiver(conn, nullNoticeReceiver, NULL);") conn-ptr)
    521520        (wait-for-connection! conn PQconnectPoll)
    522521        (set-finalizer! conn disconnect)
     
    582581(define (column-names result)
    583582  (let ((ptr (pg-result-ptr result)))
    584    (let loop ((names '())
    585               (column (column-count result)))
    586      (if (= column 0)
    587          names
    588          (loop (cons (string->symbol (PQfname ptr (sub1 column))) names)
    589                (sub1 column))))))
     583    (let loop ((names '())
     584               (column (column-count result)))
     585      (if (= column 0)
     586          names
     587          (loop (cons (string->symbol (PQfname ptr (sub1 column))) names)
     588                (sub1 column))))))
    590589
    591590(define (column-index result name)
     
    636635(define (value-at* result column row raw)
    637636  (let ((ptr (pg-result-ptr result)))
    638    (if (PQgetisnull ptr row column)
    639        (sql-null)
    640        (let* ((len (PQgetlength ptr row column))
    641               (fmt (PQfformat ptr column))
    642               (value (case fmt
    643                        ((0) (make-string len))
    644                        ((1) (make-blob len))
    645                        (else (postgresql-error
    646                               'internal 'value-at
    647                               (conc "Unknown column format type: " fmt)
    648                               result column row raw)))))
    649          (memcpy value (PQgetvalue-ptr ptr row column) len)
    650        (if (or raw (blob? value))
    651            value
    652            ((vector-ref (pg-result-value-parsers result) column) value))))))
     637    (if (PQgetisnull ptr row column)
     638        (sql-null)
     639        (let* ((len (PQgetlength ptr row column))
     640               (fmt (PQfformat ptr column))
     641               (value (case fmt
     642                        ((0) (make-string len))
     643                        ((1) (make-blob len))
     644                        (else (postgresql-error
     645                               'internal 'value-at
     646                               (conc "Unknown column format type: " fmt)
     647                               result column row raw)))))
     648          (memcpy value (PQgetvalue-ptr ptr row column) len)
     649          (if (or raw (blob? value))
     650              value
     651              ((vector-ref (pg-result-value-parsers result) column) value))))))
    653652
    654653(define (value-at result #!optional (column 0) (row 0) #!key raw)
     
    955954            "        fmts[i] = C_unfix(C_block_item(obj, 0));"
    956955            "        lens[i] = C_unfix(C_block_item(obj, 1));"
    957             "        vals[i] = (const char *)C_data_pointer(C_block_item(obj, 2));"
     956            "        vals[i] = C_c_string(C_block_item(obj, 2));"
    958957            "    }"
    959958            "}"
     
    10361035    ;; user tries to jump into/out of transactions with continuations?
    10371036    (handle-exceptions exn
    1038       (begin
    1039         (pg-connection-transaction-depth-set! conn old-depth)
    1040         (rollback!)
    1041         (raise exn))
     1037        (begin
     1038          (pg-connection-transaction-depth-set! conn old-depth)
     1039          (rollback!)
     1040          (raise exn))
    10421041      (let ((res (thunk)))
    10431042        (pg-connection-transaction-depth-set! conn old-depth)
     
    10791078  (let ((conn-ptr (pg-connection-ptr conn))
    10801079        (conn-fd (pgsql-connection->fd conn)))
    1081    (let loop ((res (PQputCopyEnd conn-ptr error-message)))
    1082      (cond
    1083       ((= res 0)
    1084        (thread-wait-for-i/o! conn-fd #:output)
    1085        (loop (PQputCopyEnd conn-ptr error-message)))
    1086       ((= res 1) (get-last-result conn))
    1087       ((= res -1)
    1088        (postgresql-error
    1089         'i/o 'put-copy-end
    1090         (conc "Error ending put COPY data. " (PQerrorMessage conn-ptr))
    1091         conn error-message))
    1092       (else
    1093        (postgresql-error
    1094         'internal 'put-copy-end
    1095         (conc "Internal error! Unexpected return value: " res) conn))))))
     1080    (let loop ((res (PQputCopyEnd conn-ptr error-message)))
     1081      (cond
     1082       ((= res 0)
     1083        (thread-wait-for-i/o! conn-fd #:output)
     1084        (loop (PQputCopyEnd conn-ptr error-message)))
     1085       ((= res 1) (get-last-result conn))
     1086       ((= res -1)
     1087        (postgresql-error
     1088         'i/o 'put-copy-end
     1089         (conc "Error ending put COPY data. " (PQerrorMessage conn-ptr))
     1090         conn error-message))
     1091       (else
     1092        (postgresql-error
     1093         'internal 'put-copy-end
     1094         (conc "Internal error! Unexpected return value: " res) conn))))))
    10961095
    10971096(define (get-copy-data conn #!key (format 'text))
     
    11461145(define (quote-identifier conn str)
    11471146  (cond-expand
    1148    (has-PQescapeIdentifier
    1149     (define %escape-ident
    1150       (foreign-lambda c-string* PQescapeIdentifier pgconn* scheme-pointer size_t))
    1151     (or (%escape-ident (pg-connection-ptr conn) str (string-length str))
    1152         (postgresql-error 'internal 'quote-identifier
    1153                           (conc "Identifier escaping failed. "
    1154                                 (PQerrorMessage conn)) conn str)))
    1155    (else (postgresql-error 'unsupported-version 'quote-identifier
    1156                            (conc "Please upgrade your PostgreSQL to 9.0 or later "
    1157                                  "in order to be able to use quote-identifier!")
    1158                            conn str))))
     1147    (has-PQescapeIdentifier
     1148     (define %escape-ident
     1149       (foreign-lambda c-string* PQescapeIdentifier pgconn* scheme-pointer size_t))
     1150     (or (%escape-ident (pg-connection-ptr conn) str (string-length str))
     1151         (postgresql-error 'internal 'quote-identifier
     1152                           (conc "Identifier escaping failed. "
     1153                                 (PQerrorMessage conn)) conn str)))
     1154    (else (postgresql-error 'unsupported-version 'quote-identifier
     1155                            (conc "Please upgrade your PostgreSQL to 9.0 or later "
     1156                                  "in order to be able to use quote-identifier!")
     1157                            conn str))))
    11591158
    11601159(define (escape-bytea conn obj)
     
    11701169           (buf (%escape-bytea-conn (pg-connection-ptr conn) data
    11711170                                    (##sys#size data) (location allocated))))
    1172      (if buf
    1173          (let* ((string-length (sub1 allocated))
    1174                 (result-string (make-string string-length)))
    1175            (memcpy result-string buf string-length)
    1176            (free buf)
    1177            result-string)
    1178          (postgresql-error
    1179           'internal 'escape-bytea
    1180           (conc "Byte array escaping failed. " (PQerrorMessage conn)) conn obj)))))
     1171      (if buf
     1172          (let* ((string-length (sub1 allocated))
     1173                 (result-string (make-string string-length)))
     1174            (memcpy result-string buf string-length)
     1175            (free buf)
     1176            result-string)
     1177          (postgresql-error
     1178           'internal 'escape-bytea
     1179           (conc "Byte array escaping failed. " (PQerrorMessage conn)) conn obj)))))
    11811180
    11821181(define (unescape-bytea str)
     
    12001199(define (make-result-fold item-count sub-item-count extract-item)
    12011200  (lambda (kons knil result)
    1202    (let ((items (item-count result))
    1203          (sub-items (sub-item-count result)))
    1204      (let loop ((seed knil)
    1205                 (item 0))
    1206        (if (= item items)
    1207            seed
    1208            (loop (kons (extract-item result item sub-items #f) seed) (add1 item)))))))
     1201    (let ((items (item-count result))
     1202          (sub-items (sub-item-count result)))
     1203      (let loop ((seed knil)
     1204                 (item 0))
     1205        (if (= item items)
     1206            seed
     1207            (loop (kons (extract-item result item sub-items #f) seed) (add1 item)))))))
    12091208
    12101209(define row-fold (make-result-fold row-count column-count row-values*))
     
    12681267  (if (and result ((foreign-lambda bool PQbinaryTuples pgresult*)
    12691268                   (pg-result-ptr result)))
    1270      'binary 'text))
     1269      'binary 'text))
    12711270
    12721271(define (copy-query*-fold kons knil conn query
     
    12751274         (data-format (result-format result)))
    12761275    (handle-exceptions exn
    1277       (let cleanup () (if (result? (get-copy-data conn)) (raise exn) (cleanup)))
     1276        (let cleanup () (if (result? (get-copy-data conn)) (raise exn) (cleanup)))
    12781277      (let loop ((data (get-copy-data conn format: data-format))
    12791278                 (seed knil))
     
    12941293         (data-format (result-format result)))
    12951294    (handle-exceptions exn
    1296       (let cleanup () (if (result? (get-copy-data conn)) (raise exn) (cleanup)))
     1295        (let cleanup () (if (result? (get-copy-data conn)) (raise exn) (cleanup)))
    12971296      (let loop ((data (get-copy-data conn format: data-format)))
    12981297        (if (result? data)
     
    13311330                       (lambda () (put-copy-end conn) (set! closed? #t)))))
    13321331    (handle-exceptions exn
    1333       (if closed?
    1334           (raise exn)
    1335           (handle-exceptions _
     1332        (if closed?
    13361333            (raise exn)
    1337             ;; Previously written data will be discarded to guarantee atomicity
    1338             (put-copy-end conn "Chicken PostgreSQL egg -- forcing error")))
     1334            (handle-exceptions _
     1335                (raise exn)
     1336              ;; Previously written data will be discarded to guarantee atomicity
     1337              (put-copy-end conn "Chicken PostgreSQL egg -- forcing error")))
    13391338      (call-with-values (lambda () (proc output-port))
    13401339        (lambda args
Note: See TracChangeset for help on using the changeset viewer.