|#
;;;; PostgreSQL Interface
-;;; package: (runtime postgresql)
+;;; package: (pgsql)
(declare (usual-integrations))
\f
-(define-primitives
- (pq-clear 1)
- (pq-cmd-status 1)
- (pq-cmd-tuples 1)
- (pq-connect-db 2)
- (pq-connect-poll 1)
- (pq-connect-start 2)
- (pq-db 1)
- (pq-end-copy 1)
- (pq-error-message 1)
- (pq-escape-bytea 1)
- (pq-escape-string 2)
- (pq-exec 3)
- (pq-field-name 2)
- (pq-finish 1)
- (pq-get-is-null? 3)
- (pq-get-line 2)
- (pq-get-value 3)
- (pq-host 1)
- (pq-make-empty-pg-result 3)
- (pq-n-fields 1)
- (pq-n-tuples 1)
- (pq-options 1)
- (pq-pass 1)
- (pq-port 1)
- (pq-put-line 2)
- (pq-res-status 1)
- (pq-reset 1)
- (pq-reset-poll 1)
- (pq-reset-start 1)
- (pq-result-error-message 1)
- (pq-result-status 1)
- (pq-status 1)
- (pq-tty 1)
- (pq-unescape-bytea 1)
- (pq-user 1))
+(C-include "pgsql")
+
+(define-integrable (every-loop proc ref string start end)
+ (let loop ((i start))
+ (if (fix:< i end)
+ (and (proc (ref string i))
+ (loop (fix:+ i 1)))
+ #t)))
+
+(define (->bytes string)
+ (if (and (or (bytevector? string)
+ (and (ustring? string)
+ (fix:= 1 (ustring-cp-size string))))
+ (let ((end (string-length string)))
+ (every-loop (lambda (cp) (fix:< cp #x80))
+ cp1-ref string 0 end)))
+ string
+ (string->utf8 string)))
+
+(declare (integrate-operator bytes-length))
+(define (bytes-length bytes)
+ (if (bytevector? bytes)
+ (bytevector-length bytes)
+ (string-length bytes)))
+
+(define-integrable (pq-clear handle)
+ (C-call "PQclear" handle))
+
+(define-integrable (peek-cstring alien)
+ (let ((bv (c-peek-cstring alien)))
+ (if (bytevector? bv)
+ (utf8->string bv)
+ bv)))
+
+(define-integrable (pq-cmd-status handle)
+ (peek-cstring (C-call "PQcmdStatus" (make-alien 'char) handle)))
+
+(define-integrable (pq-cmd-tuples handle)
+ (peek-cstring (C-call "PQcmdTuples" (make-alien 'char) handle)))
+
+(define-integrable (pq-connect-db conninfo weak-pair)
+ (weak-set-cdr! weak-pair
+ (C-call "PQconnectdb" (make-alien '|PGconn|) conninfo)))
+
+(define-integrable (pq-connect-poll handle)
+ (C-call "PQconnectPoll" handle))
+
+(define-integrable (pq-connect-start conninfo weak-pair)
+ (weak-set-cdr! weak-pair
+ (C-call "PQconnectStart" (make-alien '|PGconn|) conninfo)))
+
+(define-integrable (pq-db handle)
+ (peek-cstring (C-call "PQdb" handle)))
+
+(define-integrable (pq-end-copy handle)
+ (C-call "PQendcopy" handle))
+
+(define-integrable (pq-error-message conn)
+ (peek-cstring (C-call "PQerrorMessage" (make-alien 'char) conn)))
+
+(define (pq-escape-bytea string)
+ (peek-memory string
+ (lambda (memory bytes length)
+ (C-call "PQescapeBytea" (memory-alien memory)
+ bytes (bytes-length bytes) length))))
+
+(define (peek-memory string callout)
+ (let ((bytes (->bytes string))
+ (memory (create-memory))
+ (length (malloc (c-sizeof "size_t") '|size_t|)))
+ (callout memory bytes length)
+ (if (alien-null? (memory-alien memory))
+ (error "insufficient memory")
+ (let* ((nbytes (C-> length "size_t")) ;includes terminating #\null
+ (bv (make-bytevector nbytes)))
+ (c-peek-bytes (memory-alien memory) 0 nbytes bv 0)
+ (free length)
+ (free-memory memory)
+ bv))))
+
+(define (free-memory memory)
+ (remove-from-gc-finalizer! memories memory))
+
+(define (create-memory)
+ (make-gc-finalized-object
+ memories
+ (lambda (p)
+ (weak-set-cdr! p (make-alien 'uchar)))
+ (lambda (alien)
+ (make-memory alien))))
+
+(declare (integrate-operator pq-escape-string))
+(define (pq-escape-string bytes escaped)
+ (C-call "PQescapeString" escaped bytes (bytes-length bytes)))
+
+(define-integrable (pq-exec handle query weak-pair)
+ (weak-set-cdr! weak-pair
+ (C-call "PQexec" (make-alien '|PQresult|) handle query)))
+
+(define-integrable (pq-field-name handle index)
+ (peek-cstring (C-call "PQfname" (make-alien 'char) handle index)))
+
+(define-integrable (pq-finish handle)
+ (C-call "PQfinish" handle))
+
+(define-integrable (pq-freemem handle)
+ (if (not (alien-null? handle))
+ (without-interruption
+ (lambda ()
+ (C-call "PQfreemem" handle)
+ (alien-null! handle)))))
+
+(define-integrable (pq-get-is-null? result tup-num field-num)
+ (= 1 (C-call "PQgetisnull" result tup-num field-num)))
+
+(define-integrable (pq-get-line conn buffer length)
+ (C-call "PQgetline" conn buffer length))
+
+(define-integrable (pq-get-value handle tup-num field-num)
+ (peek-cstring (C-call "PQgetvalue" (make-alien 'char)
+ handle tup-num field-num)))
+
+(define-integrable (pq-host handle)
+ (peek-cstring (C-call "PQhost" handle)))
+
+(define-integrable (pq-make-empty-pg-result handle status weak-pair)
+ (weak-set-cdr! weak-pair
+ (C-call "PQmakeEmptyPGresult" (make-alien '|PQresult|)
+ handle status)))
+
+(define-integrable (pq-n-fields handle)
+ (C-call "PQnfields" handle))
+
+(define-integrable (pq-n-tuples handle)
+ (C-call "PQntuples" handle))
+
+(define-integrable (pq-options handle)
+ (peek-cstring (C-call "PQoptions" (make-alien 'char) handle)))
+
+(define-integrable (pq-pass handle)
+ (peek-cstring (C-call "PQpass" (make-alien 'char) handle)))
+
+(define-integrable (pq-port handle)
+ (peek-cstring (C-call "PQport" (make-alien 'char) handle)))
+
+(define-integrable (pq-put-line handle buffer)
+ (C-call "PQputline" handle buffer))
+
+(define-integrable (pq-res-status status)
+ (peek-cstring (C-call "PQresStatus" (make-alien 'char) status)))
+
+(define-integrable (pq-reset handle)
+ (C-call "PQreset" handle))
+
+(define-integrable (pq-reset-poll handle)
+ (C-call "PQresetPoll" handle))
+
+(define-integrable (pq-reset-start handle)
+ (C-call "PQresetStart" handle))
+
+(define-integrable (pq-result-error-message handle)
+ (peek-cstring (C-call "PQresultErrorMessage" (make-alien 'char) handle)))
+
+(define-integrable (pq-result-status handle)
+ (C-call "PQresultStatus" handle))
+
+(define-integrable (pq-status handle)
+ (C-call "PQstatus" handle))
+
+(define-integrable (pq-tty handle)
+ (peek-cstring (C-call "PQtty" (make-alien 'char) handle)))
+
+(define (pq-unescape-bytea string)
+ (peek-memory string
+ (lambda (memory bytes length)
+ (C-call "PQunescapeBytea" (memory-alien memory)
+ bytes length))))
+
+(define-integrable (pq-user handle)
+ (peek-cstring (C-call "PQuser" (make-alien 'char) handle)))
\f
(define-syntax define-enum
(sc-macro-transformer
(define pgsql-initialized? #f)
(define connections)
(define results)
+(define memories)
(define-structure connection handle)
(define-structure result handle)
+(define-structure memory alien)
(define-syntax define-guarantee
(sc-macro-transformer
(define-guarantee connection "PostgreSQL connection")
(define-guarantee result "PostgreSQL query result")
-(define (pgsql-available?)
- (load-library-object-file "prpgsql" #f)
- (and (implemented-primitive-procedure? (ucode-primitive pq-connect-db 2))
- (begin
- (if (not pgsql-initialized?)
- (begin
- (set! connections
- (make-gc-finalizer pq-finish
- connection?
- connection-handle
- set-connection-handle!))
- (set! results
- (make-gc-finalizer pq-clear
- result?
- result-handle
- set-result-handle!))
- (set! pgsql-initialized? #t)))
- #t)))
-
-(define (guarantee-pgsql-available)
- (if (not (pgsql-available?))
- (error "This Scheme system was built without PostgreSQL support.")))
+(define (initialize-package!)
+ (if (not pgsql-initialized?)
+ (begin
+ (set! connections
+ (make-gc-finalizer pq-finish
+ connection?
+ connection-handle
+ set-connection-handle!))
+ (set! results
+ (make-gc-finalizer pq-clear
+ result?
+ result-handle
+ set-result-handle!))
+ (set! memories
+ (make-gc-finalizer pq-freemem
+ memory?
+ memory-alien
+ set-memory-alien!))
+ (set! pgsql-initialized? #t))))
\f
(define condition-type:pgsql-error
(make-condition-type 'PGSQL-ERROR condition-type:error '()
(string-end))))
\f
(define (open-pgsql-conn parameters #!optional wait?)
- (guarantee-pgsql-available)
(let ((wait? (if (default-object? wait?) #t wait?)))
(make-gc-finalized-object
connections
(pq-connect-db parameters p)
(pq-connect-start parameters p)))
(lambda (handle)
- (cond ((= 0 handle)
+ (cond ((alien-null? handle)
(error:pgsql-connection #f))
((= PGSQL-CONNECTION-BAD (pq-status handle))
(let ((msg (pq-error-message handle)))
(index->name (pq-status (connection->handle connection)) connection-status))
(define (pgsql-get-line connection buffer)
- (pq-get-line (connection->handle connection) buffer))
+ (pq-get-line (connection->handle connection)
+ buffer (bytevector-length buffer)))
(define (pgsql-put-line connection buffer)
(pq-put-line (connection->handle connection) buffer))
(pq-end-copy (connection->handle connection)))
(define (escape-pgsql-string string)
- (guarantee-pgsql-available)
- (let ((escaped (make-string (fix:* 2 (string-length string)))))
- (string-head escaped (pq-escape-string string escaped))))
+ (let* ((bytes (->bytes string))
+ (length (bytes-length bytes))
+ (escaped-bytes (malloc (fix:1+ (fix:* 2 length)) 'char))
+ (escaped-string (begin
+ (pq-escape-string bytes escaped-bytes)
+ (peek-cstring escaped-bytes))))
+ (free escaped-bytes)
+ escaped-string))
(define (encode-pgsql-bytea bytes)
- (guarantee-pgsql-available)
(pq-escape-bytea bytes))
(define (decode-pgsql-bytea string)
- (guarantee-pgsql-available)
(pq-unescape-bytea string))
\f
(define (exec-pgsql-query connection query)
(lambda (p)
(pq-exec handle query p))
(lambda (result-handle)
- (if (= 0 result-handle)
+ (if (alien-null? result-handle)
(error "Unable to execute PostgreSQL query:" query))
(make-result result-handle))))))
(if (not (memq (pgsql-result-status result)
(error "Unable to create PostgreSQL result:" status))
(make-result result-handle)))))
-(define-integrable (result->handle result)
- (guarantee-valid-result result 'RESULT->HANDLE))
+(define-integrable (result->handle result operator)
+ (guarantee-valid-result result operator))
(define-syntax define-result-accessor
(sc-macro-transformer
(lambda (form environment)
environment
(if (syntax-match? '(SYMBOL) (cdr form))
- (let ((field (cadr form)))
- `(DEFINE (,(symbol 'PGSQL- field) OBJECT)
- (,(symbol 'PQ- field) (RESULT->HANDLE OBJECT))))
+ (let* ((field (cadr form))
+ (operator (symbol 'PGSQL- field)))
+ `(DEFINE (,operator OBJECT)
+ (,(symbol 'PQ- field) (RESULT->HANDLE OBJECT ',operator))))
(ill-formed-syntax form)))))
(define-result-accessor result-error-message)
(define-result-accessor cmd-status)
(define (pgsql-result-status result)
- (index->name (pq-result-status (result->handle result)) exec-status))
+ (index->name (pq-result-status (result->handle result 'pgsql-result-status))
+ exec-status))
(define (pgsql-clear result)
(remove-from-gc-finalizer! results result))
(define (pgsql-field-name result index)
- (pq-field-name (result->handle result) index))
+ (pq-field-name (result->handle result 'pgsql-field-name) index))
(define (pgsql-get-value result row column)
- (let ((handle (result->handle result)))
+ (let ((handle (result->handle result 'pgsql-get-value)))
(if (pq-get-is-null? handle row column)
#f
(pq-get-value handle row column))))
(define (pgsql-get-is-null? result row column)
- (pq-get-is-null? (result->handle result) row column))
+ (pq-get-is-null? (result->handle result 'pgsql-get-is-null?) row column))
(define (pgsql-cmd-tuples result)
- (string->number (pq-cmd-tuples (result->handle result))))
+ (string->number (pq-cmd-tuples (result->handle result 'pgsql-cmd-tuples))))
\ No newline at end of file