libgdbm-dev (-lgdbm)
@item mcrypt
libmcrypt-dev (-lmcrypt)
-@item pgsql
+@item postgresql
libpq-dev (-lpq)
@item X11
libx11-dev (-lX11)
[Use Berkeley DB v4 library if available [[yes]]]))
: ${with_db_4='yes'}
-AC_ARG_WITH([libpq],
- AS_HELP_STRING([--with-libpq],
- [Use PostgreSQL libpq library if available [[yes]]]))
-: ${with_libpq='yes'}
-
AC_ARG_WITH([termcap],
AS_HELP_STRING([--with-termcap],
[Use a termcap library if available [[yes]]]))
])
fi
-dnl PostgreSQL support
-if test "${with_libpq}" != no; then
- if test "${with_libpq}" != yes; then
- libpq_inc=${with_libpq}/include
- libpq_lib=${with_libpq}/lib
- else
- AC_PATH_PROG([PG_CONFIG], [pg_config])
- if test "x${PG_CONFIG}" != x; then
- libpq_inc=`${PG_CONFIG} --includedir 2>/dev/null`
- libpq_lib=`${PG_CONFIG} --libdir 2>/dev/null`
- else
- if test -d /usr/include/postgresql; then
- libpq_inc=/usr/include/postgresql
- else
- libpq_inc=/usr/include
- fi
- libpq_lib=/usr/lib
- fi
- fi
- if test "x${libpq_inc}" != x; then
- if test "${libpq_inc}" != /usr/include; then
- CPPFLAGS="${CPPFLAGS} -I${libpq_inc}"
- fi
- fi
- if test "x${libpq_lib}" != x; then
- if test "${libpq_lib}" != /usr/lib; then
- LDFLAGS="${LDFLAGS} -L${libpq_lib}"
- fi
- fi
- AC_CHECK_HEADER([libpq-fe.h],
- [
- AC_DEFINE([HAVE_LIBPQ_FE_H], [1],
- [Define to 1 if you have the <libpq-fe.h> header file.])
- AC_CHECK_LIB([pq], [PQconnectdb],
- [
- AC_DEFINE([HAVE_LIBPQ], [1],
- [Define to 1 if you have the `pq' library (-lpq).])
- MODULE_LIBS="-lpq ${MODULE_LIBS}"
- MODULE_BASES="${MODULE_BASES} prpgsql"
- ])
- ])
-fi
-
dnl Add support for X if present.
if test "${no_x}" != yes; then
if test "x${x_includes}" != x; then
prdb4.so: prdb4.o @MODULE_LOADER@
$(LINK_MODULE) prdb4.o -ldb-4 $(MODULE_LIBS)
-prpgsql.so: prpgsql.o @MODULE_LOADER@
- $(LINK_MODULE) prpgsql.o -lpq $(MODULE_LIBS)
-
prx11.so: prx11.o x11base.o x11color.o x11graph.o x11term.o @MODULE_LOADER@
$(LINK_MODULE) prx11.o x11base.o x11color.o x11graph.o x11term.o \
-lX11 $(MODULE_LIBS)
"cmpint"
"comutl"
"prmcrypt"
-"prpgsql"
"pruxdld"
"pruxffi"
"prx11"
#### Makefile for Scheme under Win32 compiled by Microsoft Visual C++.
!include <win32.mak>
-#USER_PRIM_SOURCES = prmd5.c prpgsql.c
-#USER_PRIM_OBJECTS = prmd5.obj prpgsql.obj
-#USER_LIBS = md5.lib pq.lib
+#USER_PRIM_SOURCES = prmd5.c
+#USER_PRIM_OBJECTS = prmd5.obj
+#USER_LIBS = md5.lib
# **** Microsoft supplies their assembler as a separate product, and
# **** we don't currently have a copy, so use the Watcom assembler.
wind.obj: wind.c $(OBSTACK_H) $(DSTACK_H) $(OUTF_H)
prmd5.obj: prmd5.c $(SCHEME_H) $(PRIMS_H)
-prpgsql.obj: prpgsql.c $(SCHEME_H) $(PRIMS_H) $(USRDEF_H) $(OS_H)
prosenv.obj: prosenv.c $(SCHEME_H) $(PRIMS_H) $(OSENV_H) $(OSTOP_H) $(LIMITS_H)
prosfile.obj: prosfile.c $(SCHEME_H) $(PRIMS_H) $(OSFILE_H)
prosfs.obj: prosfs.c $(SCHEME_H) $(PRIMS_H) $(OSFILE_H) $(OSFS_H) $(OSIO_H)
#### Makefile for Scheme under Win32 compiled by Watcom C/C++
### This makefile is meant to be used with Watcom make.
-USER_PRIM_SOURCES = # prmd5.c prpgsql.c
-USER_PRIM_OBJECTS = # prmd5.obj prpgsql.obj
-USER_LIBS = library wsock32.lib #,md5.lib,pq.lib
+USER_PRIM_SOURCES = # prmd5.c
+USER_PRIM_OBJECTS = # prmd5.obj
+USER_LIBS = library wsock32.lib #,md5.lib
CC = wcc386
M4 = m4
+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017, 2018 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., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-/* Interface to PostgreSQL libpq library */
-
-#include "scheme.h"
-#include "prims.h"
-#include "usrdef.h"
-#include "os.h"
-
-#ifdef HAVE_LIBPQ_FE_H
-# include <libpq-fe.h>
-#endif
-\f
-#define ARG_CONN(n) ((PGconn *) (arg_ulong_integer (n)))
-#define ARG_RESULT(n) ((PGresult *) (arg_ulong_integer (n)))
-#define ARG_EXEC_STATUS(n) ((ExecStatusType) (arg_ulong_integer (n)))
-
-#define ANY_TO_UINT(x) (ulong_to_integer ((unsigned long) (x)))
-#define ANY_TO_UNSPECIFIC(x) ((x), UNSPECIFIC)
-
-#define ONE_ARG(get_arg, fn, cvt) \
-{ \
- PRIMITIVE_HEADER (1); \
- PRIMITIVE_RETURN (cvt (fn (get_arg (1)))); \
-}
-
-#define STRING_TO_UINT(fn) ONE_ARG (STRING_ARG, fn, ANY_TO_UINT)
-
-#define CONN_TO_UINT(fn) ONE_ARG (ARG_CONN, fn, ANY_TO_UINT)
-#define CONN_TO_INT(fn) ONE_ARG (ARG_CONN, fn, long_to_integer)
-#define CONN_TO_UNSPECIFIC(fn) ONE_ARG (ARG_CONN, fn, ANY_TO_UNSPECIFIC)
-#define CONN_TO_STRING(fn) ONE_ARG (ARG_CONN, fn, char_pointer_to_string)
-
-#define RESULT_TO_UINT(fn) ONE_ARG (ARG_RESULT, fn, ANY_TO_UINT)
-#define RESULT_TO_INT(fn) ONE_ARG (ARG_RESULT, fn, long_to_integer)
-#define RESULT_TO_UNSPECIFIC(fn) ONE_ARG (ARG_RESULT, fn, ANY_TO_UNSPECIFIC)
-#define RESULT_TO_STRING(fn) ONE_ARG (ARG_RESULT, fn, char_pointer_to_string)
-
-DEFINE_PRIMITIVE ("PQ-CONNECT-DB", Prim_pq_connect_db, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- CHECK_ARG (2, WEAK_PAIR_P);
- SET_PAIR_CDR ((ARG_REF (2)), (ANY_TO_UINT (PQconnectdb (STRING_ARG (1)))));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("PQ-CONNECT-START", Prim_pq_connect_start, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- CHECK_ARG (2, WEAK_PAIR_P);
- SET_PAIR_CDR ((ARG_REF (2)),
- (ANY_TO_UINT (PQconnectStart (STRING_ARG (1)))));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("PQ-CONNECT-POLL", Prim_pq_connect_poll, 1, 1, 0)
- CONN_TO_UINT (PQconnectPoll)
-
-DEFINE_PRIMITIVE ("PQ-STATUS", Prim_pq_status, 1, 1, 0)
- CONN_TO_UINT (PQstatus)
-
-DEFINE_PRIMITIVE ("PQ-FINISH", Prim_pq_finish, 1, 1, 0)
- CONN_TO_UNSPECIFIC (PQfinish)
-
-DEFINE_PRIMITIVE ("PQ-RESET", Prim_pq_reset, 1, 1, 0)
- CONN_TO_UNSPECIFIC (PQreset)
-
-DEFINE_PRIMITIVE ("PQ-RESET-START", Prim_pq_reset_start, 1, 1, 0)
- CONN_TO_INT (PQresetStart)
-
-DEFINE_PRIMITIVE ("PQ-RESET-POLL", Prim_pq_reset_poll, 1, 1, 0)
- CONN_TO_UINT (PQresetPoll)
-
-DEFINE_PRIMITIVE ("PQ-DB", Prim_pq_db, 1, 1, 0)
- CONN_TO_STRING (PQdb)
-
-DEFINE_PRIMITIVE ("PQ-USER", Prim_pq_user, 1, 1, 0)
- CONN_TO_STRING (PQuser)
-
-DEFINE_PRIMITIVE ("PQ-PASS", Prim_pq_pass, 1, 1, 0)
- CONN_TO_STRING (PQpass)
-
-DEFINE_PRIMITIVE ("PQ-HOST", Prim_pq_host, 1, 1, 0)
- CONN_TO_STRING (PQhost)
-
-DEFINE_PRIMITIVE ("PQ-PORT", Prim_pq_port, 1, 1, 0)
- CONN_TO_STRING (PQport)
-
-DEFINE_PRIMITIVE ("PQ-TTY", Prim_pq_tty, 1, 1, 0)
- CONN_TO_STRING (PQtty)
-
-DEFINE_PRIMITIVE ("PQ-OPTIONS", Prim_pq_options, 1, 1, 0)
- CONN_TO_STRING (PQoptions)
-
-DEFINE_PRIMITIVE ("PQ-ERROR-MESSAGE", Prim_pq_error_message, 1, 1, 0)
- CONN_TO_STRING (PQerrorMessage)
-\f
-DEFINE_PRIMITIVE ("PQ-EXEC", Prim_pq_exec, 3, 3, 0)
-{
- PRIMITIVE_HEADER (3);
- CHECK_ARG (3, WEAK_PAIR_P);
- SET_PAIR_CDR ((ARG_REF (3)),
- (ANY_TO_UINT (PQexec ((ARG_CONN (1)), (STRING_ARG (2))))));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("PQ-MAKE-EMPTY-PG-RESULT", Prim_pq_make_empty_pg_result,
- 3, 3, 0)
-{
- PRIMITIVE_HEADER (3);
- CHECK_ARG (3, WEAK_PAIR_P);
- SET_PAIR_CDR ((ARG_REF (3)),
- (ANY_TO_UINT (PQmakeEmptyPGresult ((ARG_CONN (1)),
- (ARG_EXEC_STATUS (1))))));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("PQ-RESULT-STATUS", Prim_pq_result_status, 1, 1, 0)
- RESULT_TO_UINT (PQresultStatus)
-
-DEFINE_PRIMITIVE ("PQ-RES-STATUS", Prim_pq_res_status, 1, 1, 0)
- ONE_ARG (ARG_EXEC_STATUS, PQresStatus, char_pointer_to_string)
-
-DEFINE_PRIMITIVE ("PQ-RESULT-ERROR-MESSAGE", Prim_pq_result_error_message,
- 1, 1, 0)
- RESULT_TO_STRING (PQresultErrorMessage)
-
-DEFINE_PRIMITIVE ("PQ-CLEAR", Prim_pq_clear, 1, 1, 0)
- RESULT_TO_UNSPECIFIC (PQclear)
-
-DEFINE_PRIMITIVE ("PQ-N-TUPLES", Prim_pq_n_tuples, 1, 1, 0)
- RESULT_TO_INT (PQntuples)
-
-DEFINE_PRIMITIVE ("PQ-N-FIELDS", Prim_pq_n_fields, 1, 1, 0)
- RESULT_TO_INT (PQnfields)
-
-DEFINE_PRIMITIVE ("PQ-FIELD-NAME", Prim_pq_fname, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- PRIMITIVE_RETURN
- (char_pointer_to_string (PQfname ((ARG_RESULT (1)),
- (arg_integer (2)))));
-}
-
-DEFINE_PRIMITIVE ("PQ-GET-VALUE", Prim_pq_get_value, 3, 3, 0)
-{
- PRIMITIVE_HEADER (3);
- PRIMITIVE_RETURN
- (char_pointer_to_string (PQgetvalue ((ARG_RESULT (1)),
- (arg_integer (2)),
- (arg_integer (3)))));
-}
-
-DEFINE_PRIMITIVE ("PQ-GET-IS-NULL?", Prim_pq_get_is_null, 3, 3, 0)
-{
- PRIMITIVE_HEADER (3);
- PRIMITIVE_RETURN
- (BOOLEAN_TO_OBJECT (PQgetisnull ((ARG_RESULT (1)),
- (arg_integer (2)),
- (arg_integer (3)))));
-}
-
-DEFINE_PRIMITIVE ("PQ-CMD-STATUS", Prim_pq_cmd_status, 1, 1, 0)
- RESULT_TO_STRING (PQcmdStatus)
-
-DEFINE_PRIMITIVE ("PQ-CMD-TUPLES", Prim_pq_cmd_tuples, 1, 1, 0)
- RESULT_TO_STRING (PQcmdTuples)
-\f
-DEFINE_PRIMITIVE ("PQ-GET-LINE", Prim_pq_get_line, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- CHECK_ARG (2, STRING_P);
- PRIMITIVE_RETURN
- (long_to_integer (PQgetline ((ARG_CONN (1)),
- (STRING_POINTER (ARG_REF (2))),
- (STRING_LENGTH (ARG_REF (2))))));
-}
-
-DEFINE_PRIMITIVE ("PQ-PUT-LINE", Prim_pq_put_line, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- CHECK_ARG (2, STRING_P);
- PRIMITIVE_RETURN
- (long_to_integer (PQputnbytes ((ARG_CONN (1)),
- (STRING_POINTER (ARG_REF (2))),
- (STRING_LENGTH (ARG_REF (2))))));
-}
-
-DEFINE_PRIMITIVE ("PQ-END-COPY", Prim_pq_end_copy, 1, 1, 0)
- CONN_TO_INT (PQendcopy)
-
-DEFINE_PRIMITIVE ("PQ-ESCAPE-STRING", Prim_pq_escape_string, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- CHECK_ARG (1, STRING_P);
- PRIMITIVE_RETURN
- (ulong_to_integer (PQescapeString ((STRING_ARG (2)),
- (STRING_POINTER (ARG_REF (1))),
- (STRING_LENGTH (ARG_REF (1))))));
-}
-
-DEFINE_PRIMITIVE ("PQ-ESCAPE-BYTEA", Prim_pq_escape_bytea, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- CHECK_ARG (1, STRING_P);
- {
- size_t escaped_length;
- unsigned char * escaped
- = (PQescapeBytea ((STRING_BYTE_PTR (ARG_REF (1))),
- (STRING_LENGTH (ARG_REF (1))),
- (&escaped_length)));
- SCHEME_OBJECT s = (memory_to_string ((escaped_length - 1), escaped));
- PQfreemem (escaped);
- PRIMITIVE_RETURN (s);
- }
-}
-
-DEFINE_PRIMITIVE ("PQ-UNESCAPE-BYTEA", Prim_pq_unescape_bytea, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- {
- size_t unescaped_length;
- unsigned char * unescaped
- = (PQunescapeBytea (((unsigned char *) (STRING_ARG (1))),
- (&unescaped_length)));
- if (unescaped == 0)
- error_bad_range_arg (1);
- {
- SCHEME_OBJECT s = (memory_to_string (unescaped_length, unescaped));
- PQfreemem (unescaped);
- PRIMITIVE_RETURN (s);
- }
- }
-}
-\f
-#ifdef COMPILE_AS_MODULE
-
-char *
-dload_initialize_file (void)
-{
- declare_primitive ("PQ-CONNECT-DB", Prim_pq_connect_db, 2, 2, 0);
- declare_primitive ("PQ-CONNECT-START", Prim_pq_connect_start, 2, 2, 0);
- declare_primitive ("PQ-CONNECT-POLL", Prim_pq_connect_poll, 1, 1, 0);
- declare_primitive ("PQ-STATUS", Prim_pq_status, 1, 1, 0);
- declare_primitive ("PQ-FINISH", Prim_pq_finish, 1, 1, 0);
- declare_primitive ("PQ-RESET", Prim_pq_reset, 1, 1, 0);
- declare_primitive ("PQ-RESET-START", Prim_pq_reset_start, 1, 1, 0);
- declare_primitive ("PQ-RESET-POLL", Prim_pq_reset_poll, 1, 1, 0);
- declare_primitive ("PQ-DB", Prim_pq_db, 1, 1, 0);
- declare_primitive ("PQ-USER", Prim_pq_user, 1, 1, 0);
- declare_primitive ("PQ-PASS", Prim_pq_pass, 1, 1, 0);
- declare_primitive ("PQ-HOST", Prim_pq_host, 1, 1, 0);
- declare_primitive ("PQ-PORT", Prim_pq_port, 1, 1, 0);
- declare_primitive ("PQ-TTY", Prim_pq_tty, 1, 1, 0);
- declare_primitive ("PQ-OPTIONS", Prim_pq_options, 1, 1, 0);
- declare_primitive ("PQ-ERROR-MESSAGE", Prim_pq_error_message, 1, 1, 0);
- declare_primitive ("PQ-EXEC", Prim_pq_exec, 3, 3, 0);
- declare_primitive
- ("PQ-MAKE-EMPTY-PG-RESULT", Prim_pq_make_empty_pg_result, 3, 3, 0);
- declare_primitive ("PQ-RESULT-STATUS", Prim_pq_result_status, 1, 1, 0);
- declare_primitive ("PQ-RES-STATUS", Prim_pq_res_status, 1, 1, 0);
- declare_primitive
- ("PQ-RESULT-ERROR-MESSAGE", Prim_pq_result_error_message, 1, 1, 0);
- declare_primitive ("PQ-CLEAR", Prim_pq_clear, 1, 1, 0);
- declare_primitive ("PQ-N-TUPLES", Prim_pq_n_tuples, 1, 1, 0);
- declare_primitive ("PQ-N-FIELDS", Prim_pq_n_fields, 1, 1, 0);
- declare_primitive ("PQ-FIELD-NAME", Prim_pq_fname, 2, 2, 0);
- declare_primitive ("PQ-GET-VALUE", Prim_pq_get_value, 3, 3, 0);
- declare_primitive ("PQ-GET-IS-NULL?", Prim_pq_get_is_null, 3, 3, 0);
- declare_primitive ("PQ-CMD-STATUS", Prim_pq_cmd_status, 1, 1, 0);
- declare_primitive ("PQ-CMD-TUPLES", Prim_pq_cmd_tuples, 1, 1, 0);
- declare_primitive ("PQ-GET-LINE", Prim_pq_get_line, 2, 2, 0);
- declare_primitive ("PQ-PUT-LINE", Prim_pq_put_line, 2, 2, 0);
- declare_primitive ("PQ-END-COPY", Prim_pq_end_copy, 1, 1, 0);
- declare_primitive ("PQ-ESCAPE-STRING", Prim_pq_escape_string, 2, 2, 0);
- declare_primitive ("PQ-ESCAPE-BYTEA", Prim_pq_escape_bytea, 1, 1, 0);
- declare_primitive ("PQ-UNESCAPE-BYTEA", Prim_pq_unescape_bytea, 1, 1, 0);
- return ("#prpgsql");
-}
-
-#endif /* COMPILE_AS_MODULE */
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
02110-1301, USA.
+mit-scheme-pgsql 1.0 - Matt Birkholz, 2018-06-22
+================================================
+
+Replace the prpgsql µmodule. Change the option name to "postgresql".
+Rename the import procedure "import-postgresql". The deprecated
+(runtime postgresql) package now autoloads this plugin.
+
mit-scheme-pgsql 0.1 - Matt Birkholz, 2017-07-02
================================================
-The PGSQL option.
+The PostgreSQL option.
-This plugin creates a (pgsql) package, a drop-in replacement for the
-microcode module based (runtime postgresql) package. It is built in the
-customary GNU way:
+This plugin creates a (postgresql) package. It is built in the customary
+GNU way:
./configure ...
make all check install
To use:
- (load-option 'pgsql)
- (import-pgsql)
+ (load-option 'postgresql)
+ (import-postgresql)
-Import-pgsql will modify the REPL's current environment by adding
+Import-postgresql will modify the REPL's current environment by adding
bindings linked to the plugin's exports. They are not exported to the
-global environment because they would conflict with the exports from
-(runtime postgresql).
+global environment because they would conflict with the deprecated
+exports from (runtime postgresql).
To import into a CREF package set, add this to your .pkg file:
(define-package (your package name)
(parent (your package parent))
- (import (pgsql)
+ (import (postgresql)
call-with-pgsql-conn
...))
AC_PREREQ([2.69])
AC_INIT([MIT/GNU Scheme pgsql plugin],
- [0.1],
+ [1.0],
[bug-mit-scheme@gnu.org],
[mit-scheme-pgsql])
AC_CONFIG_SRCDIR([pgsql.pkg])
(lambda ()
(load-package-set "pgsql")))
-(add-subsystem-identification! "PGSQL" '(0 1))
\ No newline at end of file
+(add-subsystem-identification! "PostgreSQL" '(1 0))
\ No newline at end of file
set -e
${MIT_SCHEME_EXE} --prepend-library . <<\EOF
(load-option 'PGSQL)
-(load "pgsql-check" (->environment '(pgsql)))
+(load "pgsql-check" (->environment '(postgresql)))
EOF
(global-definitions runtime/)
-(define-package (pgsql)
+(define-package (postgresql)
(files "pgsql")
(parent ())
(initialization (initialize-package!))
ustring-cp-size
ustring?)
(export ()
- import-pgsql)
- (export (pgsql global)
+ import-postgresql)
+ (export (postgresql global)
call-with-pgsql-conn
close-pgsql-conn
condition-type:pgsql-connection-error
poll-pgsql-conn
poll-pgsql-reset))
-(define-package (pgsql global)
+(define-package (postgresql global)
;; Just to get cref to analyze whether all exports are defined.
)
\ No newline at end of file
|#
;;;; PostgreSQL Interface
-;;; package: (pgsql)
+;;; package: (postgresql)
(declare (usual-integrations))
\f
-(define (import-pgsql)
+(define (import-postgresql)
(let ((target-environment (nearest-repl/environment))
- (source-environment (->environment '(pgsql))))
+ (source-environment (->environment '(postgresql))))
(for-each (lambda (name)
(link-variables target-environment name
source-environment name))
(format (runtime format) (initialize-package!) "format")
(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")
(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))
-\f
-(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 enum index))
-
-(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)
-\f
-(define pgsql-initialized? #f)
-(define connections)
-(define results)
+;;; Access to the PostgreSQL library is now accomplished with the FFI
+;;; rather than a microcode module. The bindings in this package are
+;;; linked to those in the (pgsql) package after the plugin is loaded.
-(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 type '?))
- (guarantee-type (symbol 'guarantee- type))
- (error:not-type (symbol 'error:not- type))
- (guarantee-valid-type (symbol 'guarantee-valid- type))
- (type-handle (symbol 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 linked? #f)
(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.")))
-\f
-(define condition-type:pgsql-error
- (make-condition-type 'pgsql-error condition-type:error '()
- (lambda (condition port)
- condition
- (write-string "Unknown PostgreSQL error." port))))
-
-(define condition-type:pgsql-connection-error
- (make-condition-type 'pgsql-connection-error condition-type:pgsql-error
- '(message)
- (lambda (condition port)
- (write-string "Unable to connect to PostgreSQL server" port)
- (write-message (access-condition condition 'message) port))))
-
-(define error:pgsql-connection
- (condition-signaller condition-type:pgsql-connection-error
- '(message)
- standard-error-handler))
-
-(define condition-type:pgsql-query-error
- (make-condition-type 'pgsql-query-error condition-type:pgsql-error
- '(query result)
- (lambda (condition port)
- (write-string "PostgreSQL query error" port)
- (write-message
- (pgsql-result-error-message (access-condition condition 'result))
- port))))
-
-(define error:pgsql-query
- (condition-signaller condition-type:pgsql-query-error
- '(query result)
- standard-error-handler))
-
-(define (write-message string port)
- (if string
- (begin
- (write-string ": " port)
- (write-string
- (let ((result (regsexp-match-string error-regsexp string)))
- (if result
- (cdr (assv 'message (cddr result)))
- string))
- port))
- (write-string "." port)))
-
-(define error-regsexp
- (compile-regsexp
- '(seq (string-start)
- (* (char-in whitespace))
- (? (string-ci "error:"))
- (* (char-in whitespace))
- (group message (* (any-char)))
- (* (char-in whitespace))
- (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
- (lambda (p)
- (if wait?
- (pq-connect-db parameters p)
- (pq-connect-start parameters p)))
- (lambda (handle)
- (cond ((= 0 handle)
- (error:pgsql-connection #f))
- ((= pgsql-connection-bad (pq-status handle))
- (let ((msg (pq-error-message handle)))
- (pq-finish handle)
- (error:pgsql-connection msg))))
- (make-connection handle)))))
-
-(define (close-pgsql-conn connection)
- (remove-from-gc-finalizer! connections connection))
-
-(define (call-with-pgsql-conn parameters procedure)
- (let ((conn))
- (dynamic-wind (lambda ()
- (set! conn (open-pgsql-conn parameters))
- unspecific)
- (lambda ()
- (procedure conn))
- (lambda ()
- (close-pgsql-conn conn)
- (set! conn)
- unspecific))))
-
-(define (pgsql-conn-open? connection)
- (guarantee-connection connection 'pgsql-conn-open?)
- (if (connection-handle connection) #t #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))
-\f
-(define-syntax define-connection-accessor
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (if (syntax-match? '(symbol) (cdr form))
- (let ((field (cadr form)))
- `(define (,(symbol 'pgsql-conn- field) object)
- (,(symbol '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 (pq-status (connection->handle connection)) connection-status))
-
-(define (pgsql-get-line connection buffer)
- (pq-get-line (connection->handle connection) buffer))
-
-(define (pgsql-put-line connection buffer)
- (pq-put-line (connection->handle connection) buffer))
-
-(define (pgsql-end-copy connection)
- (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))))
-
-(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)
- (guarantee string? query 'exec-pgsql-query)
- (let ((result
- (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))))))
- (if (not (memq (pgsql-result-status result)
- '(pgsql-command-ok
- pgsql-tuples-ok
- pgsql-copy-out
- pgsql-copy-in)))
- (error:pgsql-query query result))
- result))
-
-(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 'pgsql- field) object)
- (,(symbol 'pq- field) (result->handle object))))
- (ill-formed-syntax form)))))
-
-(define-result-accessor result-error-message)
-(define-result-accessor n-tuples)
-(define-result-accessor n-fields)
-(define-result-accessor cmd-status)
-
-(define (pgsql-result-status result)
- (index->name (pq-result-status (result->handle result)) 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))
-
-(define (pgsql-get-value result row column)
- (let ((handle (result->handle result)))
- (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))
-
-(define (pgsql-cmd-tuples result)
- (string->number (pq-cmd-tuples (result->handle result))))
+ (and (plugin-available? "pgsql")
+ (or linked?
+ (begin
+ (load-option 'pgsql)
+ (link!)
+ #t))))
+
+(define (link!)
+ (for-each
+ (let ((runtime (->environment '(runtime postgresql)))
+ (pgsql (->environment '(pgsql))))
+ (lambda (name)
+ (environment-link-name runtime pgsql name)))
+ names)
+ (set! linked? #t))
+
+(define names
+ '(call-with-pgsql-conn
+ close-pgsql-conn
+ condition-type:pgsql-connection-error
+ condition-type:pgsql-error
+ condition-type:pgsql-query-error
+ decode-pgsql-bytea
+ encode-pgsql-bytea
+ escape-pgsql-string
+ exec-pgsql-query
+ guarantee-pgsql-available
+ make-empty-pgsql-result
+ open-pgsql-conn
+ 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-open?
+ 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-line
+ 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-put-line
+ pgsql-result-error-message
+ pgsql-result-status
+ pgsql-tuples-ok
+ poll-pgsql-conn
+ poll-pgsql-reset))
+
+(define call-with-pgsql-conn)
+(define close-pgsql-conn)
+(define condition-type:pgsql-connection-error)
+(define condition-type:pgsql-error)
+(define condition-type:pgsql-query-error)
+(define decode-pgsql-bytea)
+(define encode-pgsql-bytea)
+(define escape-pgsql-string)
+(define exec-pgsql-query)
+(define guarantee-pgsql-available)
+(define make-empty-pgsql-result)
+(define open-pgsql-conn)
+(define pgsql-bad-response)
+(define pgsql-clear)
+(define pgsql-cmd-status)
+(define pgsql-cmd-tuples)
+(define pgsql-command-ok)
+(define pgsql-conn-db)
+(define pgsql-conn-error-message)
+(define pgsql-conn-host)
+(define pgsql-conn-open?)
+(define pgsql-conn-options)
+(define pgsql-conn-pass)
+(define pgsql-conn-port)
+(define pgsql-conn-reset)
+(define pgsql-conn-reset-start)
+(define pgsql-conn-status)
+(define pgsql-conn-tty)
+(define pgsql-conn-user)
+(define pgsql-connection-auth-ok)
+(define pgsql-connection-awaiting-response)
+(define pgsql-connection-bad)
+(define pgsql-connection-made)
+(define pgsql-connection-ok)
+(define pgsql-connection-setenv)
+(define pgsql-connection-started)
+(define pgsql-copy-in)
+(define pgsql-copy-out)
+(define pgsql-empty-query)
+(define pgsql-fatal-error)
+(define pgsql-field-name)
+(define pgsql-get-is-null?)
+(define pgsql-get-line)
+(define pgsql-get-value)
+(define pgsql-n-fields)
+(define pgsql-n-tuples)
+(define pgsql-nonfatal-error)
+(define pgsql-polling-active)
+(define pgsql-polling-failed)
+(define pgsql-polling-ok)
+(define pgsql-polling-reading)
+(define pgsql-polling-writing)
+(define pgsql-put-line)
+(define pgsql-result-error-message)
+(define pgsql-result-status)
+(define pgsql-tuples-ok)
+(define poll-pgsql-conn)
+(define poll-pgsql-reset)
\ No newline at end of file
((load) "pgsql")
(else))
(parent (runtime))
- (export ()
+ (export () deprecated:postgresql
call-with-pgsql-conn
close-pgsql-conn
condition-type:pgsql-connection-error
projects / mit-scheme.git / commitdiff