From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 8 Jun 2003 05:07:12 +0000 (+0000)
Subject: Add initial draft of PostgreSQL support.
X-Git-Tag: 20090517-FFI~1889
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=197cc5be1ddecea2a83d45d03808880eabfee29d;p=mit-scheme.git

Add initial draft of PostgreSQL support.
---

diff --git a/v7/src/runtime/Makefile.in b/v7/src/runtime/Makefile.in
index 375ef9f8e..eda2af8f5 100644
--- a/v7/src/runtime/Makefile.in
+++ b/v7/src/runtime/Makefile.in
@@ -1,6 +1,6 @@
-# $Id: Makefile.in,v 1.8 2003/02/14 18:28:32 cph Exp $
+# $Id: Makefile.in,v 1.9 2003/06/08 05:06:56 cph Exp $
 #
-# Copyright (c) 2000, 2001 Massachusetts Institute of Technology
+# Copyright 2000,2001,2003 Massachusetts Institute of Technology
 #
 # This file is part of MIT/GNU Scheme.
 #
@@ -66,7 +66,7 @@ mkinstalldirs = $(SHELL) $(top_srcdir)/mkinstalldirs
 AUXDIR = @AUXDIR@
 RODIR = $(AUXDIR)/options
 RUNOPTS = chrsyn cpress format gdbm hashtb krypt mime-codec numint optiondb \
-	  ordvec process rbtree regexp rexp rgxcmp syncproc wttree ystep
+	  ordvec pgsql process rbtree regexp rexp rgxcmp syncproc wttree ystep
 
 all:
 	echo "No ALL action"
diff --git a/v7/src/runtime/ed-ffi.scm b/v7/src/runtime/ed-ffi.scm
index 5d665daae..36128c98b 100644
--- a/v7/src/runtime/ed-ffi.scm
+++ b/v7/src/runtime/ed-ffi.scm
@@ -1,6 +1,6 @@
 #| -*- Scheme -*-
 
-$Id: ed-ffi.scm,v 1.35 2003/02/14 18:28:32 cph Exp $
+$Id: ed-ffi.scm,v 1.36 2003/06/08 05:07:00 cph Exp $
 
 Copyright (c) 1991,1996,1997,1999,2000 Massachusetts Institute of Technology
 Copyright (c) 2001,2002,2003 Massachusetts Institute of Technology
@@ -112,6 +112,7 @@ USA.
     ("parser-buffer" (runtime parser-buffer))
     ("partab"	(runtime parser-table))
     ("pathnm"	(runtime pathname))
+    ("pgsql"	(runtime postgresql))
     ("poplat"	(runtime population))
     ("port"	(runtime port))
     ("pp"	(runtime pretty-printer))
diff --git a/v7/src/runtime/optiondb.scm b/v7/src/runtime/optiondb.scm
index ae9696be7..c0b225214 100644
--- a/v7/src/runtime/optiondb.scm
+++ b/v7/src/runtime/optiondb.scm
@@ -1,8 +1,9 @@
 #| -*-Scheme-*-
 
-$Id: optiondb.scm,v 1.16 2003/02/14 18:28:33 cph Exp $
+$Id: optiondb.scm,v 1.17 2003/06/08 05:07:04 cph Exp $
 
-Copyright (c) 1994-2002 Massachusetts Institute of Technology
+Copyright 1994,1995,1996,1999,2000,2001 Massachusetts Institute of Technology
+Copyright 2003 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -69,6 +70,7 @@ USA.
    (KRYPT	(RUNTIME KRYPT)		#F			"krypt")
    (MIME-CODEC	(RUNTIME MIME-CODEC)	#F			"mime-codec")
    (ORDERED-VECTOR (RUNTIME ORDERED-VECTOR) #F			"ordvec")
+   (POSTGRESQL	(RUNTIME POSTGRESQL)	#F			"pgsql")
    (RB-TREE	(RUNTIME RB-TREE)	#F			"rbtree")
    (STEPPER	(RUNTIME STEPPER)	#F			"ystep")
    (SUBPROCESS	(RUNTIME SUBPROCESS)	(INITIALIZE-PACKAGE!)	"process")
diff --git a/v7/src/runtime/pgsql.scm b/v7/src/runtime/pgsql.scm
new file mode 100644
index 000000000..32e42471d
--- /dev/null
+++ b/v7/src/runtime/pgsql.scm
@@ -0,0 +1,274 @@
+#| -*-Scheme-*-
+
+$Id: pgsql.scm,v 1.1 2003/06/08 05:07:07 cph Exp $
+
+Copyright 2003 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+USA.
+
+|#
+
+;;;; PostgreSQL Interface
+;;; package: (runtime postgresql)
+
+(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-error-message 1)
+  (pq-escape-string 2)
+  (pq-exec 3)
+  (pq-field-name 2)
+  (pq-finish 1)
+  (pq-get-is-null? 3)
+  (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-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-user 1))
+
+(define-syntax define-enum
+  (sc-macro-transformer
+   (lambda (form environment)
+     environment
+     (if (syntax-match? '(IDENTIFIER * IDENTIFIER) (cdr form))
+	 `(BEGIN
+	    ,@(let loop ((names (cddr form)) (index 0))
+		(if (pair? names)
+		     `((DEFINE ,(car names) ,index)
+		       ,@(loop (cdr names) (+ index 1)))
+		     '()))
+	    (DEFINE ,(cadr form) '#(,@(cddr form))))
+	 (ill-formed-syntax form)))))
+
+(define (index->name index enum)
+  (guarantee-index-fixnum index 'INDEX->NAME)
+  (if (not (fix:< index (vector-length enum)))
+      (error:bad-range-argument index 'INDEX->NAME))
+  (vector-ref index enum))
+
+(define-enum connection-status
+  PGSQL-CONNECTION-OK
+  PGSQL-CONNECTION-BAD
+  PGSQL-CONNECTION-STARTED
+  PGSQL-CONNECTION-MADE
+  PGSQL-CONNECTION-AWAITING-RESPONSE
+  PGSQL-CONNECTION-AUTH-OK
+  PGSQL-CONNECTION-SETENV)
+
+(define-enum postgres-polling-status
+  PGSQL-POLLING-FAILED
+  PGSQL-POLLING-READING
+  PGSQL-POLLING-WRITING
+  PGSQL-POLLING-OK
+  PGSQL-POLLING-ACTIVE)
+
+(define-enum exec-status
+  PGSQL-EMPTY-QUERY
+  PGSQL-COMMAND-OK
+  PGSQL-TUPLES-OK
+  PGSQL-COPY-OUT
+  PGSQL-COPY-IN
+  PGSQL-BAD-RESPONSE
+  PGSQL-NONFATAL-ERROR
+  PGSQL-FATAL-ERROR)
+
+(define pgsql-initialized? #f)
+(define connections)
+(define results)
+
+(define-structure connection handle)
+(define-structure result handle)
+
+(define-syntax define-guarantee
+  (sc-macro-transformer
+   (lambda (form environment)
+     environment
+     (if (syntax-match? '(SYMBOL EXPRESSION) (cdr form))
+	 (let ((type (cadr form)))
+	   (let ((type? (symbol-append type '?))
+		 (guarantee-type (symbol-append 'GUARANTEE- type))
+		 (error:not-type (symbol-append 'ERROR:NOT- type))
+		 (guarantee-valid-type (symbol-append 'GUARANTEE-VALID- type))
+		 (type-handle (symbol-append type '-HANDLE)))
+	     `(BEGIN
+		(DEFINE-INTEGRABLE (,guarantee-type OBJECT CALLER)
+		  (IF (NOT (,type? OBJECT))
+		      (,error:not-type OBJECT CALLER)))
+		(DEFINE (,error:not-type OBJECT CALLER)
+		  (ERROR:WRONG-TYPE-ARGUMENT OBJECT ,(caddr form) CALLER))
+		(DEFINE-INTEGRABLE (,guarantee-valid-type OBJECT CALLER)
+		  (IF (AND (,type? OBJECT) (,type-handle OBJECT))
+		      (,type-handle OBJECT)
+		      (,error:not-type OBJECT CALLER))))))
+	 (ill-formed-syntax form)))))
+
+(define-guarantee connection "PostgreSQL connection")
+(define-guarantee result "PostgreSQL query result")
+
+(define (pgsql-available?)
+  (load-library-object-file "prpgsql" #f)
+  (and (implemented-primitive-procedure? pq-connect-db)
+       (begin
+	 (if (not pgsql-initialized?)
+	     (begin
+	       (set! connections (make-gc-finalizer pq-finish))
+	       (set! pgsql-initialized? #t)))
+	 #t)))
+
+(define (open-pgsql-conn parameters #!optional wait?)
+  (let ((wait? (if (default-object? wait?) #t wait?)))
+    (make-gc-finalized-object
+     connections
+     (lambda (p)
+       (if wait?
+	   (pq-connect-db parameters p)
+	   (pq-connect-start parameters p)))
+     (lambda (handle)
+       (cond ((= 0 handle)
+	      (error "Unable to connect to PostgreSQL server."))
+	     ((= PGSQL-CONNECTION-BAD (pq-status handle))
+	      (let ((msg (pq-error-message handle)))
+		(pq-finish handle)
+		(error "Unable to connect to PostgreSQL server:" msg))))
+       (make-connection handle)))))
+
+(define (close-pgsql-conn connection)
+  (guarantee-connection connection 'CLOSE-PGSQL-CONN)
+  (without-interrupts
+   (lambda ()
+     (if (connection-handle connection)
+	 (begin
+	   (remove-from-gc-finalizer! connections connection)
+	   (set-connection-handle! connection #f))))))
+
+(define-integrable (connection->handle connection)
+  (guarantee-valid-connection connection 'CONNECTION->HANDLE))
+
+(define (poll-pgsql-conn connection)
+  (index->name (pq-connect-poll (connection->handle connection))
+	       postgres-polling-status))
+
+(define (poll-pgsql-reset connection)
+  (index->name (pq-reset-poll (connection->handle connection))
+	       postgres-polling-status))
+
+(define-syntax define-connection-accessor
+  (sc-macro-transformer
+   (lambda (form environment)
+     environment
+     (if (syntax-match? '(SYMBOL) (cdr form))
+	 (let ((field (cadr form)))
+	   `(DEFINE (,(symbol-append 'PGSQL-CONN- field) OBJECT)
+	      (,(symbol-append 'PQ- field) (CONNECTION->HANDLE OBJECT))))
+	 (ill-formed-syntax form)))))
+
+(define-connection-accessor db)
+(define-connection-accessor user)
+(define-connection-accessor pass)
+(define-connection-accessor host)
+(define-connection-accessor port)
+(define-connection-accessor tty)
+(define-connection-accessor options)
+(define-connection-accessor reset)
+(define-connection-accessor reset-start)
+(define-connection-accessor error-message)
+
+(define (pgsql-conn-status connection)
+  (index->name (connection->handle connection) connection-status))
+
+(define (escape-pgsql-string string)
+  (let ((escaped (make-string (fix:* 2 (string-length string)))))
+    (set-string-maximum-length! escaped (pq-escape-string string escaped))
+    escaped))
+
+(define (exec-pgsql-query connection query)
+  (guarantee-string query 'EXEC-PGSQL-QUERY)
+  (let ((handle (connection->handle connection)))
+    (make-gc-finalized-object
+     results
+     (lambda (p)
+       (pq-exec handle query p))
+     (lambda (result-handle)
+       (if (= 0 result-handle)
+	   (error "Unable to execute PostgreSQL query:" query))
+       (make-result result-handle)))))
+
+(define (make-empty-pgsql-result connection status)
+  (let ((handle (connection->handle connection)))
+    (make-gc-finalized-object
+     results
+     (lambda (p)
+       (pq-make-empty-pg-result handle status p))
+     (lambda (result-handle)
+       (if (= 0 result-handle)
+	   (error "Unable to create PostgreSQL result:" status))
+       (make-result result-handle)))))
+
+(define-integrable (result->handle result)
+  (guarantee-valid-result result 'RESULT->HANDLE))
+
+(define-syntax define-result-accessor
+  (sc-macro-transformer
+   (lambda (form environment)
+     environment
+     (if (syntax-match? '(SYMBOL) (cdr form))
+	 (let ((field (cadr form)))
+	   `(DEFINE (,(symbol-append 'PGSQL- field) OBJECT)
+	      (,(symbol-append 'PQ- field) (RESULT->HANDLE OBJECT))))
+	 (ill-formed-syntax form)))))
+
+(define-result-accessor result-status)
+(define-result-accessor result-error-message)
+(define-result-accessor clear)
+(define-result-accessor n-tuples)
+(define-result-accessor n-fields)
+(define-result-accessor cmd-status)
+
+(define (pgsql-res-status status)
+  (pq-res-status status))
+
+(define (pgsql-field-name result index)
+  (pq-field-name (result->handle result) index))
+
+(define (pgsql-get-value result row column)
+  (pq-get-value (result->handle result) row column))
+
+(define (pgsql-get-is-null? result row column)
+  (pq-get-is-null? (result->handle result) row column))
+
+(define (pgsql-cmd-tuples result)
+  (string->number (pq-cmd-tuples (result->handle result))))
\ No newline at end of file
diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 29b5c0530..41110766d 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.446 2003/06/08 04:07:12 cph Exp $
+$Id: runtime.pkg,v 14.447 2003/06/08 05:07:12 cph Exp $
 
 Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
 Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology
@@ -4600,4 +4600,61 @@ USA.
 	  url:match:xchar
 	  url:parse:hostport
 	  url:string-encoded?
-	  url:substring-encoded?))
\ No newline at end of file
+	  url:substring-encoded?))
+
+(define-package (runtime postgresql)
+  (file-case options
+    ((load) "pgsql")
+    (else))
+  (parent (runtime))
+  (export ()
+	  close-pgsql-conn
+	  escape-pgsql-string
+	  exec-pgsql-query
+	  make-empty-pgsql-result
+	  open-pgsql-conn
+	  pgsql-available?
+	  pgsql-bad-response
+	  pgsql-clear
+	  pgsql-cmd-status
+	  pgsql-cmd-tuples
+	  pgsql-command-ok
+	  pgsql-conn-db
+	  pgsql-conn-error-message
+	  pgsql-conn-host
+	  pgsql-conn-options
+	  pgsql-conn-pass
+	  pgsql-conn-port
+	  pgsql-conn-reset
+	  pgsql-conn-reset-start
+	  pgsql-conn-status
+	  pgsql-conn-tty
+	  pgsql-conn-user
+	  pgsql-connection-auth-ok
+	  pgsql-connection-awaiting-response
+	  pgsql-connection-bad
+	  pgsql-connection-made
+	  pgsql-connection-ok
+	  pgsql-connection-setenv
+	  pgsql-connection-started
+	  pgsql-copy-in
+	  pgsql-copy-out
+	  pgsql-empty-query
+	  pgsql-fatal-error
+	  pgsql-field-name
+	  pgsql-get-is-null?
+	  pgsql-get-value
+	  pgsql-n-fields
+	  pgsql-n-tuples
+	  pgsql-nonfatal-error
+	  pgsql-polling-active
+	  pgsql-polling-failed
+	  pgsql-polling-ok
+	  pgsql-polling-reading
+	  pgsql-polling-writing
+	  pgsql-res-status
+	  pgsql-result-error-message
+	  pgsql-result-status
+	  pgsql-tuples-ok
+	  poll-pgsql-conn
+	  poll-pgsql-reset))
\ No newline at end of file