summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--postgresql.scm136
-rw-r--r--tests/run.scm32
2 files changed, 85 insertions, 83 deletions
diff --git a/postgresql.scm b/postgresql.scm
index d2c4a03..801df81 100644
--- a/postgresql.scm
+++ b/postgresql.scm
@@ -55,6 +55,7 @@
wait-for-notifications!)
(import scheme
+ (scheme base)
(chicken base)
(chicken foreign)
(chicken string)
@@ -63,7 +64,6 @@
(chicken condition)
(chicken format)
(chicken gc)
- (chicken blob)
(chicken time)
srfi-1
srfi-4
@@ -145,13 +145,7 @@
(define PQputCopyEnd (foreign-lambda int PQputCopyEnd pgconn* (const c-string)))
(define PQgetCopyData (foreign-lambda int PQgetCopyData pgconn* (c-pointer (c-pointer char)) bool))
-(define memcpy (foreign-lambda c-pointer "C_memcpy" scheme-pointer c-pointer size_t))
-
-(define (srfi-4-vector? x) ; Copied from ##sys#srfi-4-vector? from 4.8.3
- (and (##core#inline "C_blockp" x)
- (##sys#generic-structure? x)
- (memq (##sys#slot x 0)
- '(u8vector u16vector s8vector s16vector u32vector s32vector f32vector f64vector))))
+(define memcpy (foreign-lambda c-pointer "C_memcpy" nonnull-scheme-pointer c-pointer size_t))
;; TODO: Create a real callback system?
(foreign-declare "static void nullNoticeReceiver(void *arg, const PGresult *res){ }")
@@ -409,7 +403,7 @@
(define default-type-unparsers
(make-parameter
`((,string? . ,(lambda (conn s) s))
- (,u8vector? . ,(lambda (conn v) (u8vector->blob/shared v)))
+ (,bytevector? . ,(lambda (conn v) v))
(,char? . ,(lambda (conn c) (string c)))
(,boolean? . ,bool-unparser)
(,number? . ,(lambda (conn n) (number->string n)))
@@ -462,7 +456,7 @@
(let ((conn-fd (pgsql-connection->fd conn))
(t ##sys#current-thread))
(when delay (##sys#thread-block-for-timeout!
- t (+ (current-milliseconds) delay)))
+ t (+ (current-process-milliseconds) delay)))
(##sys#thread-block-for-i/o! t conn-fd in/out)
(##sys#thread-yield!)))
@@ -504,23 +498,23 @@
(cond-expand
(has-connectdb-params
(let ((len (length spec)))
- ((foreign-lambda* pgconn* ((scheme-object cons) (scheme-pointer keybuf)
+ ((foreign-lambda* pgconn* ((scheme-object lst) (scheme-pointer keybuf)
(scheme-pointer valbuf) (int len))
"const char **key = (const char **)keybuf;"
"const char **val = (const char **)valbuf;"
"int i;"
- "for (i=0; i < len; ++i,cons=C_u_i_cdr(cons)) {"
- " C_word kvpair = C_u_i_car(cons);"
- " key[i] = C_c_string(C_u_i_car(kvpair));"
- " val[i] = C_c_string(C_u_i_cdr(kvpair));"
+ "for (i=0; i < len; ++i, lst=C_u_i_cdr(lst)) {"
+ " C_word kvpair = C_u_i_car(lst);"
+ " key[i] = C_c_string(C_block_item(C_u_i_car(kvpair), 0));"
+ " val[i] = C_c_string(C_block_item(C_u_i_cdr(kvpair), 0));"
"}"
"key[len] = NULL;"
"val[len] = NULL;"
"C_return(PQconnectStartParams(key, val, 0));")
- (map (lambda (x) (cons (string-append (->string (car x)) "\x00")
- (string-append (->string (cdr x)) "\x00"))) spec)
- (make-blob (* (add1 len) (foreign-value "sizeof(char *)" int)))
- (make-blob (* (add1 len) (foreign-value "sizeof(char *)" int)))
+ (map (lambda (x) (cons (->string (car x))
+ (->string (cdr x)))) spec)
+ (make-bytevector (* (add1 len) (foreign-value "sizeof(char *)" int)))
+ (make-bytevector (* (add1 len) (foreign-value "sizeof(char *)" int)))
len)))
(else (PQconnectStart (alist->connection-spec spec))))))
@@ -670,13 +664,16 @@
(fmt (PQfformat ptr column))
(value (case fmt
((0) (make-string len))
- ((1) (make-blob len))
+ ((1) (make-bytevector len))
(else (postgresql-error
'internal 'value-at
(conc "Unknown column format type: " fmt)
- result column row raw)))))
- (memcpy value (PQgetvalue-ptr ptr row column) len)
- (if (or raw (blob? value))
+ result column row raw))))
+ (raw-value (case fmt
+ ((0) (##sys#slot value 0))
+ ((1) value))))
+ (memcpy raw-value (PQgetvalue-ptr ptr row column) len)
+ (if (or raw (bytevector? value))
value
((vector-ref (pg-result-value-parsers result) column) value))))))
@@ -982,16 +979,15 @@
(let* ((params ;; Check all params and ensure they are proper pairs
(map (lambda (p)
(let ((obj (if raw p (scheme-value->db-value conn p))))
- (cond ((string? obj) ; Convert to ASCIIZ
- (let* ((len (##sys#size obj))
- (res (string-append obj "\x00")))
- (vector 0 len res)))
- ((blob? obj)
- (vector 1 (##sys#size obj) obj))
+ (cond ((string? obj)
+ ;; Extract the raw bytevector contents from the wrapped string object
+ (vector 0 (string-length obj) (##sys#slot obj 0)))
+ ((bytevector? obj)
+ (vector 1 (bytevector-length obj) obj))
((sql-null? obj) #f)
(else (postgresql-error
'type 'query*
- (sprintf "Param value is not string, sql-null or blob: ~S" p)
+ (sprintf "Param value is not string, sql-null or bytevector/u8vector: ~S" p)
conn query params format)))))
params))
;; It's a shame we need to traverse params twice (and again in C)...
@@ -1034,9 +1030,9 @@
((send-query (pg-connection-ptr conn) query-as-string (symbol? query)
len params
;; We allocate here instead of in C to keep things simple
- (make-blob (* len (foreign-value "sizeof(char *)" int)))
- (make-blob (* len (foreign-value "sizeof(int)" int)))
- (make-blob (* len (foreign-value "sizeof(int)" int)))
+ (make-bytevector (* len (foreign-value "sizeof(char *)" int)))
+ (make-bytevector (* len (foreign-value "sizeof(int)" int)))
+ (make-bytevector (* len (foreign-value "sizeof(int)" int)))
(symbol->format format))
(get-last-result conn raw: raw))
(else (postgresql-error 'i/o 'query*
@@ -1110,15 +1106,15 @@
;;;; COPY support
;;;;;;;;;;;;;;;;;;;;
-(define (put-copy-data conn data)
- (let* ((data (cond
- ((or (string? data) (blob? data)) data)
- ((srfi-4-vector? data) (##sys#slot data 1))
- (else (postgresql-error
- 'type 'put-copy-data
- "Expected a blob, string or srfi-4 vector" conn data))))
- (len (##sys#size data))
- (conn-ptr (pg-connection-ptr conn)))
+(define (put-copy-data conn in-data)
+ (let* ((conn-ptr (pg-connection-ptr conn))
+ (data (cond ((string? in-data) (##sys#slot in-data 0))
+ ((bytevector? in-data) in-data)
+ (else (postgresql-error
+ 'type 'put-copy-data
+ "Expected a bytevector/u8vector or string" conn in-data))))
+ (len (cond ((string? in-data) (string-length in-data))
+ ((bytevector? in-data) (bytevector-length in-data)))))
(let loop ((res (PQputCopyData conn-ptr data len)))
(cond
((= res 0)
@@ -1158,14 +1154,17 @@
(let ((res (PQgetCopyData conn-ptr (location buf) #t)))
(cond
((> res 0)
- (let ((value (case format
- ((text) (make-string res))
- ((binary) (make-blob res))
- (else (postgresql-error
- 'internal 'get-copy-data
- (conc "Unknown column format type: " format)
- conn)))))
- (memcpy value buf res)
+ (let* ((value (case format
+ ((text) (make-string res))
+ ((binary) (make-bytevector res))
+ (else (postgresql-error
+ 'internal 'get-copy-data
+ (conc "Unknown column format type: " format)
+ conn))))
+ (raw-value (case format
+ ((text) (##sys#slot value 0))
+ ((binary) value))))
+ (memcpy raw-value buf res)
(free buf)
value))
((= res 0)
@@ -1195,7 +1194,7 @@
(buflen (add1 (* strlen 2)))
(buffer (make-string buflen))
(conn-ptr (pg-connection-ptr conn))
- (size (%escape-string-conn conn-ptr buffer str strlen (location err))))
+ (size (%escape-string-conn conn-ptr (##sys#slot buffer 0) (##sys#slot str 0) strlen (location err))))
(cond (err (postgresql-error 'internal 'escape-string
(conc "String escaping failed. "
(PQerrorMessage conn-ptr)) conn str))
@@ -1207,11 +1206,12 @@
(has-escape-identifier
(define %escape-ident
(foreign-lambda c-string* PQescapeIdentifier pgconn* scheme-pointer size_t))
- (or (%escape-ident (pg-connection-ptr conn) str (string-length str))
- (postgresql-error 'internal 'quote-identifier
- (conc "Identifier escaping failed: "
- (PQerrorMessage (pg-connection-ptr conn)))
- conn str)))
+ (let ((len (string-length str)))
+ (or (%escape-ident (pg-connection-ptr conn) (##sys#slot str 0) len)
+ (postgresql-error 'internal 'quote-identifier
+ (conc "Identifier escaping failed: "
+ (PQerrorMessage (pg-connection-ptr conn)))
+ conn str))))
(else (postgresql-error 'unsupported-version 'quote-identifier
(conc "Please upgrade your PostgreSQL to 9.0 or later "
"in order to be able to use quote-identifier!")
@@ -1222,18 +1222,20 @@
(foreign-lambda (c-pointer unsigned-char) PQescapeByteaConn
pgconn* scheme-pointer size_t (c-pointer size_t)))
(let-location ((allocated size_t))
- (let* ((data (cond ((or (string? obj) (blob? obj)) obj)
- ((srfi-4-vector? obj) (##sys#slot obj 1))
+ (let* ((conn-ptr (pg-connection-ptr conn))
+ (data (cond ((string? obj) (##sys#slot obj 0))
+ ((bytevector? obj) obj)
(else (postgresql-error
'type 'escape-bytea
- "Expected string, blob or srfi-4 vector" obj))))
- (conn-ptr (pg-connection-ptr conn))
+ "Expected string or bytevector/u8vector" obj))))
+ (len (cond ((string? obj) (string-length obj))
+ ((bytevector? obj) (bytevector-length obj))))
(buf (%escape-bytea-conn
- conn-ptr data (##sys#size data) (location allocated))))
+ conn-ptr data len (location allocated))))
(if buf
(let* ((string-length (sub1 allocated))
(result-string (make-string string-length)))
- (memcpy result-string buf string-length)
+ (memcpy (##sys#slot result-string 0) buf string-length)
(free buf)
result-string)
(postgresql-error
@@ -1244,13 +1246,13 @@
(define (unescape-bytea str)
(define %unescape-bytea
(foreign-lambda (c-pointer unsigned-char) PQunescapeBytea c-string (c-pointer size_t)))
- (let-location ((blob-length size_t))
- (let ((buf (%unescape-bytea str (location blob-length))))
+ (let-location ((bv-length size_t))
+ (let ((buf (%unescape-bytea str (location bv-length))))
(if buf
- (let ((result-blob (make-blob blob-length)))
- (memcpy result-blob buf blob-length)
+ (let ((result-bv (make-bytevector bv-length)))
+ (memcpy result-bv buf bv-length)
(free buf)
- (blob->u8vector/shared result-blob))
+ result-bv)
(postgresql-error 'internal 'unescape-bytea
"Byte array unescaping failed (out of memory?)" str)))))
diff --git a/tests/run.scm b/tests/run.scm
index ff4c0d2..df84a03 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -1,4 +1,4 @@
-(import (chicken blob)
+(import (scheme base)
(chicken condition)
(chicken string)
test
@@ -23,7 +23,7 @@
(test-error* (sprintf "~S" '?expr) ?error-type ?expr))))
;; Perform a quick sanity check before running the actual tests
-(condition-case (disconnect (connect '((dbname . test))))
+(condition-case (disconnect (connect '((dbname . test)) '() '()))
(exn (exn postgresql connect)
(print "Could not connect to server. Please ensure that the UNIX "
"user running these tests is allowed to connect to a database "
@@ -182,7 +182,7 @@
;; We are using two levels of escaping here because the ::bytea cast
;; performs another string interpretation. Yes, this is kinda confusing...
(test "Result value for null-terminated byte array"
- (blob->u8vector (string->blob "h\x00ello"))
+ #u8("h" 0 "ello")
(value-at (query conn "SELECT E'h\\\\000ello'::bytea")))
(test "Result value for raw null-terminated byte array"
@@ -191,16 +191,16 @@
"h\\000ello")
(value-at (query conn "SELECT E'h\\\\000ello'::bytea") 0 0 raw: #t))
- (test "Result value blob for binary string"
- (string->blob "hello")
+ (test "Result value bytevector/u8vector for binary string"
+ #u8("hello")
(value-at (query* conn "SELECT 'hello'" '() format: 'binary)))
- (test "Result value blob for binary integer"
- (u8vector->blob (u8vector 0 0 0 1))
+ (test "Result value bytevector/u8vector for binary integer"
+ (u8vector 0 0 0 1)
(value-at (query* conn "SELECT 1::int4" '() format: 'binary)))
(test "Result value for binary string with NUL bytes"
- (string->blob "h\x00ello")
+ #u8("h" 0 "ello")
(value-at (query* conn "SELECT E'h\\\\000ello'::bytea" '() format: 'binary)))
(test "Result value for array of integers"
@@ -298,9 +298,9 @@
(test-assert "NULL parameters"
(sql-null? (value-at
(query conn "SELECT $1::text" (sql-null)) 0 0)))
- (test "blob parameters"
+ (test "bytevector/u8vector parameters"
"hi"
- (value-at (query conn "SELECT $1::text" (string->blob "hi")) 0 0))
+ (value-at (query conn "SELECT $1::text" (string->utf8 "hi")) 0 0))
(test "boolean parameters"
'(#t #f)
(row-values (query conn "SELECT $1::bool, $2::bool" #t #f)))
@@ -385,9 +385,9 @@
(if (>= major-version 9)
"\\\\x576800617427730a75703f"
"Wh\\\\000at''s\\\\012up?")
- (escape-bytea conn (blob->u8vector (string->blob "Wh\x00at's\nup?"))))
- (test "Bytea is unescaped correctly (blob)"
- (blob->u8vector (string->blob "What's\nup? "))
+ (escape-bytea conn #u8("Wh" 0 "at's\nup?")))
+ (test "Bytea is unescaped correctly (bytevector)"
+ (string->utf8 "What's\nup? ")
;; The extra quote is dropped here because it wouldn't be returned
;; by pgsql either.
(unescape-bytea "What's\\012up?\\ "))
@@ -405,9 +405,9 @@
(if (>= major-version 9)
"\\x576800617427730a75703f"
"Wh\\000at''s\\012up?")
- (escape-bytea conn "Wh\x00at's\nup?"))
+ (escape-bytea conn "Wh\x00;at's\nup?"))
(test "Bytea is unescaped correctly"
- (blob->u8vector (string->blob "What's\nup? "))
+ (string->utf8 "What's\nup? ")
;; The extra quote is dropped here because it wouldn't be returned
;; by pgsql either.
(unescape-bytea "What's\\012up?\\ "))
@@ -645,7 +645,7 @@
#f
(bool-parser "f"))
(test "Byte array parsed correctly"
- (blob->u8vector/shared (string->blob "abc\x01\x02\xffdef"))
+ #u8("abc" #x01 #x02 #xff "def")
(bytea-parser "abc\\001\\002\\377def"))
(test "Char parser"
#\x
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-23 08:25:23 +0000