From: Matt Birkholz <matt@birchwood-abbey.net>
Date: Sun, 2 Jul 2017 23:17:29 +0000 (-0700)
Subject: pgsql plugin: update lost in the merge(?).
X-Git-Tag: mit-scheme-pucked-9.2.12~115
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=5c9eff5af8e4763293a2d67bbf7070b323ffbc49;p=mit-scheme.git

pgsql plugin: update lost in the merge(?).
---

diff --git a/src/pgsql/pgsql.scm b/src/pgsql/pgsql.scm
index 3dc47214a..d003a5156 100644
--- a/src/pgsql/pgsql.scm
+++ b/src/pgsql/pgsql.scm
@@ -25,46 +25,190 @@ USA.
 |#
 
 ;;;; PostgreSQL Interface
-;;; package: (runtime postgresql)
+;;; package: (pgsql)
 
 (declare (usual-integrations))
 
-(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)))
 
 (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))))
 
 (define condition-type:pgsql-error
   (make-condition-type 'PGSQL-ERROR condition-type:error '()
@@ -223,7 +366,6 @@ USA.
 	 (string-end))))
 
 (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))
 
 (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