From 5ba5696273aed5ad0122badc957b73a711a1757d Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Fri, 22 Jun 2018 04:30:45 -0700 Subject: [PATCH] =?utf8?q?Punt=20pgsql=20=C2=B5module;=20autoload=20pgsql?= =?utf8?q?=20plugin=20version=201.0.?= MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit --- doc/user-manual/user.texinfo | 2 +- src/microcode/configure.ac | 48 --- src/microcode/makegen/Makefile.in.in | 3 - src/microcode/makegen/files-optional.scm | 1 - src/microcode/ntutl/makefile | 7 +- src/microcode/ntutl/makefile.wcc | 6 +- src/microcode/prpgsql.c | 305 -------------- src/pgsql/NEWS | 7 + src/pgsql/README | 19 +- src/pgsql/configure.ac | 2 +- src/pgsql/make.scm | 2 +- src/pgsql/pgsql-check.sh | 2 +- src/pgsql/pgsql.pkg | 8 +- src/pgsql/pgsql.scm | 6 +- src/runtime/optiondb.scm | 1 - src/runtime/pgsql.scm | 491 +++++++---------------- src/runtime/runtime.pkg | 2 +- 17 files changed, 172 insertions(+), 740 deletions(-) delete mode 100644 src/microcode/prpgsql.c diff --git a/doc/user-manual/user.texinfo b/doc/user-manual/user.texinfo index 6fab500fc..c211c07ee 100644 --- a/doc/user-manual/user.texinfo +++ b/doc/user-manual/user.texinfo @@ -284,7 +284,7 @@ libssl-dev (-lcrypto) libgdbm-dev (-lgdbm) @item mcrypt libmcrypt-dev (-lmcrypt) -@item pgsql +@item postgresql libpq-dev (-lpq) @item X11 libx11-dev (-lX11) diff --git a/src/microcode/configure.ac b/src/microcode/configure.ac index 965a95f04..12bc7d8d0 100644 --- a/src/microcode/configure.ac +++ b/src/microcode/configure.ac @@ -140,11 +140,6 @@ AC_ARG_WITH([db-4], [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]]])) @@ -879,49 +874,6 @@ if test "${with_db_4}" != no; then ]) 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 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 diff --git a/src/microcode/makegen/Makefile.in.in b/src/microcode/makegen/Makefile.in.in index ac2e19de0..1d7ccfc0c 100644 --- a/src/microcode/makegen/Makefile.in.in +++ b/src/microcode/makegen/Makefile.in.in @@ -196,9 +196,6 @@ prmcrypt.so: prmcrypt.o @MODULE_LOADER@ 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) diff --git a/src/microcode/makegen/files-optional.scm b/src/microcode/makegen/files-optional.scm index 64f91a8a5..9e8e215c5 100644 --- a/src/microcode/makegen/files-optional.scm +++ b/src/microcode/makegen/files-optional.scm @@ -29,7 +29,6 @@ USA. "cmpint" "comutl" "prmcrypt" -"prpgsql" "pruxdld" "pruxffi" "prx11" diff --git a/src/microcode/ntutl/makefile b/src/microcode/ntutl/makefile index 2ff58a843..94f4f7bae 100644 --- a/src/microcode/ntutl/makefile +++ b/src/microcode/ntutl/makefile @@ -27,9 +27,9 @@ #### Makefile for Scheme under Win32 compiled by Microsoft Visual C++. !include -#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. @@ -470,7 +470,6 @@ vector.obj: vector.c $(SCHEME_H) $(PRIMS_H) 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) diff --git a/src/microcode/ntutl/makefile.wcc b/src/microcode/ntutl/makefile.wcc index 4d486a48c..0584572ed 100644 --- a/src/microcode/ntutl/makefile.wcc +++ b/src/microcode/ntutl/makefile.wcc @@ -27,9 +27,9 @@ #### 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 diff --git a/src/microcode/prpgsql.c b/src/microcode/prpgsql.c deleted file mode 100644 index 8c6da6020..000000000 --- a/src/microcode/prpgsql.c +++ /dev/null @@ -1,305 +0,0 @@ -/* -*-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 -#endif - -#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) - -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) - -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); - } - } -} - -#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 */ diff --git a/src/pgsql/NEWS b/src/pgsql/NEWS index e2fef3433..4086541a1 100644 --- a/src/pgsql/NEWS +++ b/src/pgsql/NEWS @@ -22,6 +22,13 @@ along with MIT/GNU Scheme; if not, write to the Free Software 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 ================================================ diff --git a/src/pgsql/README b/src/pgsql/README index 15a27be63..e01f882f9 100644 --- a/src/pgsql/README +++ b/src/pgsql/README @@ -1,21 +1,20 @@ -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: @@ -23,6 +22,6 @@ 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 ...)) diff --git a/src/pgsql/configure.ac b/src/pgsql/configure.ac index 048e01fe6..af5371d2d 100644 --- a/src/pgsql/configure.ac +++ b/src/pgsql/configure.ac @@ -2,7 +2,7 @@ dnl Process this file with autoconf to produce a configure script. 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]) diff --git a/src/pgsql/make.scm b/src/pgsql/make.scm index 9279ec5f6..bc7d1e3b0 100644 --- a/src/pgsql/make.scm +++ b/src/pgsql/make.scm @@ -6,4 +6,4 @@ (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 diff --git a/src/pgsql/pgsql-check.sh b/src/pgsql/pgsql-check.sh index bf8c567e9..8a67307d1 100755 --- a/src/pgsql/pgsql-check.sh +++ b/src/pgsql/pgsql-check.sh @@ -5,5 +5,5 @@ set -e ${MIT_SCHEME_EXE} --prepend-library . <<\EOF (load-option 'PGSQL) -(load "pgsql-check" (->environment '(pgsql))) +(load "pgsql-check" (->environment '(postgresql))) EOF diff --git a/src/pgsql/pgsql.pkg b/src/pgsql/pgsql.pkg index 1a1b7bcda..fe9548a75 100644 --- a/src/pgsql/pgsql.pkg +++ b/src/pgsql/pgsql.pkg @@ -26,7 +26,7 @@ USA. (global-definitions runtime/) -(define-package (pgsql) +(define-package (postgresql) (files "pgsql") (parent ()) (initialization (initialize-package!)) @@ -35,8 +35,8 @@ USA. 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 @@ -97,6 +97,6 @@ USA. 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 diff --git a/src/pgsql/pgsql.scm b/src/pgsql/pgsql.scm index 470d09377..9a7a54e7c 100644 --- a/src/pgsql/pgsql.scm +++ b/src/pgsql/pgsql.scm @@ -25,13 +25,13 @@ USA. |# ;;;; PostgreSQL Interface -;;; package: (pgsql) +;;; package: (postgresql) (declare (usual-integrations)) -(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)) diff --git a/src/runtime/optiondb.scm b/src/runtime/optiondb.scm index f5bf912b5..1a6a346ac 100644 --- a/src/runtime/optiondb.scm +++ b/src/runtime/optiondb.scm @@ -68,7 +68,6 @@ USA. (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") diff --git a/src/runtime/pgsql.scm b/src/runtime/pgsql.scm index 70f691242..5a1a8c5bb 100644 --- a/src/runtime/pgsql.scm +++ b/src/runtime/pgsql.scm @@ -29,359 +29,144 @@ USA. (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)) - -(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) - -(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."))) - -(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)))) - -(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)) - -(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)) - -(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 diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index ccd00e26d..a7a7577f6 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -5711,7 +5711,7 @@ USA. ((load) "pgsql") (else)) (parent (runtime)) - (export () + (export () deprecated:postgresql call-with-pgsql-conn close-pgsql-conn condition-type:pgsql-connection-error -- 2.25.1