pgsql plugin: update lost in the merge(?).
authorMatt Birkholz <matt@birchwood-abbey.net>
Sun, 2 Jul 2017 23:17:29 +0000 (16:17 -0700)
committerMatt Birkholz <matt@birchwood-abbey.net>
Sun, 2 Jul 2017 23:17:29 +0000 (16:17 -0700)
src/pgsql/pgsql.scm

index 3dc47214a01f9293b46b5538b1f34ee45dc52def..d003a51568da2d6c35ed8d69abb922eb61be2f3f 100644 (file)
@@ -25,46 +25,190 @@ USA.
 |#
 
 ;;;; 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
@@ -115,9 +259,11 @@ USA.
 (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
@@ -145,28 +291,25 @@ USA.
 (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 '()
@@ -223,7 +366,6 @@ USA.
         (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
@@ -232,7 +374,7 @@ USA.
           (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)))
@@ -295,7 +437,8 @@ USA.
   (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))
@@ -304,16 +447,19 @@ USA.
   (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)
@@ -325,7 +471,7 @@ USA.
            (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)
@@ -347,17 +493,18 @@ USA.
           (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)
@@ -366,22 +513,23 @@ USA.
 (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