From 41fa9e9bae605ca52d5d52a1590d7878237954a8 Mon Sep 17 00:00:00 2001 From: PostgreSQL Daemon Date: Tue, 20 Apr 2004 00:33:53 +0000 Subject: [PATCH] Remove all of the libpgtcl and pgtclsh files, including all references to them within the various makefiles with_tcl is still required for the src/pl/tcl language --- GNUmakefile.in | 4 +- configure | 121 +- configure.in | 27 +- src/Makefile.global.in | 3 +- src/bin/Makefile | 6 +- src/bin/pgtclsh/Makefile | 58 - src/bin/pgtclsh/README | 10 - src/bin/pgtclsh/pgtclAppInit.c | 112 -- src/bin/pgtclsh/pgtclUtils.tcl | 17 - src/bin/pgtclsh/pgtkAppInit.c | 114 -- src/bin/pgtclsh/updateStats.tcl | 71 - src/interfaces/Makefile | 9 +- src/interfaces/libpgtcl/Makefile | 51 - src/interfaces/libpgtcl/README | 38 - src/interfaces/libpgtcl/libpgtcl.def | 8 - src/interfaces/libpgtcl/libpgtcl.h | 24 - src/interfaces/libpgtcl/pgtcl.c | 170 --- src/interfaces/libpgtcl/pgtclCmds.c | 2081 -------------------------- src/interfaces/libpgtcl/pgtclCmds.h | 143 -- src/interfaces/libpgtcl/pgtclId.c | 862 ----------- src/interfaces/libpgtcl/pgtclId.h | 64 - src/interfaces/libpgtcl/win32.mak | 201 --- 22 files changed, 8 insertions(+), 4186 deletions(-) delete mode 100644 src/bin/pgtclsh/Makefile delete mode 100644 src/bin/pgtclsh/README delete mode 100644 src/bin/pgtclsh/pgtclAppInit.c delete mode 100644 src/bin/pgtclsh/pgtclUtils.tcl delete mode 100644 src/bin/pgtclsh/pgtkAppInit.c delete mode 100644 src/bin/pgtclsh/updateStats.tcl delete mode 100644 src/interfaces/libpgtcl/Makefile delete mode 100644 src/interfaces/libpgtcl/README delete mode 100644 src/interfaces/libpgtcl/libpgtcl.def delete mode 100644 src/interfaces/libpgtcl/libpgtcl.h delete mode 100644 src/interfaces/libpgtcl/pgtcl.c delete mode 100644 src/interfaces/libpgtcl/pgtclCmds.c delete mode 100644 src/interfaces/libpgtcl/pgtclCmds.h delete mode 100644 src/interfaces/libpgtcl/pgtclId.c delete mode 100644 src/interfaces/libpgtcl/pgtclId.h delete mode 100644 src/interfaces/libpgtcl/win32.mak diff --git a/GNUmakefile.in b/GNUmakefile.in index 5f7e6558de..65ddc7cd15 100644 --- a/GNUmakefile.in +++ b/GNUmakefile.in @@ -1,7 +1,7 @@ # # PostgreSQL top level makefile # -# $PostgreSQL: pgsql/GNUmakefile.in,v 1.37 2004/01/19 21:20:04 tgl Exp $ +# $PostgreSQL: pgsql/GNUmakefile.in,v 1.38 2004/04/20 00:33:44 pgsql Exp $ # subdir = @@ -71,8 +71,6 @@ $(distdir).tar: distdir opt_files := \ src/tools src/corba src/tutorial \ - src/bin/pgtclsh \ - $(addprefix src/interfaces/, libpgtcl) \ $(addprefix src/pl/, plperl plpython tcl) docs_files := doc/postgres.tar.gz doc/src doc/TODO.detail diff --git a/configure b/configure index 9629ef2602..8e043242df 100755 --- a/configure +++ b/configure @@ -859,9 +859,7 @@ Optional Packages: --with-libs=DIRS alternative spelling of --with-libraries --with-pgport=PORTNUM change default port number 5432 --with-tcl build Tcl and Tk interfaces - --without-tk do not build Tk interfaces if Tcl is enabled - --with-tclconfig=DIR tclConfig.sh and tkConfig.sh are in DIR - --with-tkconfig=DIR tkConfig.sh is in DIR + --with-tclconfig=DIR tclConfig.sh is in DIR --with-perl build Perl modules (PL/Perl) --with-python build Python modules (PL/Python) --with-krb4 build with Kerberos 4 support @@ -2999,44 +2997,6 @@ echo "$as_me:$LINENO: result: $with_tcl" >&5 echo "${ECHO_T}$with_tcl" >&6 -# If Tcl is enabled (above) then Tk is also, unless the user disables it using --without-tk -echo "$as_me:$LINENO: checking whether to build with Tk" >&5 -echo $ECHO_N "checking whether to build with Tk... $ECHO_C" >&6 -if test "$with_tcl" = yes; then - - - -# Check whether --with-tk or --without-tk was given. -if test "${with_tk+set}" = set; then - withval="$with_tk" - - case $withval in - yes) - : - ;; - no) - : - ;; - *) - { { echo "$as_me:$LINENO: error: no argument expected for --with-tk option" >&5 -echo "$as_me: error: no argument expected for --with-tk option" >&2;} - { (exit 1); exit 1; }; } - ;; - esac - -else - with_tk=yes - -fi; - -else - with_tk=no -fi -echo "$as_me:$LINENO: result: $with_tk" >&5 -echo "${ECHO_T}$with_tk" >&6 - - - # We see if the path to the Tcl/Tk configuration scripts is specified. # This will override the use of tclsh to find the paths to search. @@ -3066,35 +3026,6 @@ echo "$as_me: error: argument required for --with-tclconfig option" >&2;} fi; -# We see if the path to the Tk configuration scripts is specified. -# This will override the use of tclsh to find the paths to search. - - - - -# Check whether --with-tkconfig or --without-tkconfig was given. -if test "${with_tkconfig+set}" = set; then - withval="$with_tkconfig" - - case $withval in - yes) - { { echo "$as_me:$LINENO: error: argument required for --with-tkconfig option" >&5 -echo "$as_me: error: argument required for --with-tkconfig option" >&2;} - { (exit 1); exit 1; }; } - ;; - no) - { { echo "$as_me:$LINENO: error: argument required for --with-tkconfig option" >&5 -echo "$as_me: error: argument required for --with-tkconfig option" >&2;} - { (exit 1); exit 1; }; } - ;; - *) - - ;; - esac - -fi; - - # # Optionally build Perl modules (PL/Perl) # @@ -17233,51 +17164,6 @@ eval TCL_SHARED_BUILD=\"$TCL_SHARED_BUILD\" fi -# Check for Tk configuration script tkConfig.sh -if test "$with_tk" = yes; then - echo "$as_me:$LINENO: checking for tkConfig.sh" >&5 -echo $ECHO_N "checking for tkConfig.sh... $ECHO_C" >&6 -# Let user override test -if test -z "$TK_CONFIG_SH"; then - pgac_test_dirs="$with_tkconfig $with_tclconfig" - - set X $pgac_test_dirs; shift - if test $# -eq 0; then - test -z "$TCLSH" && { { echo "$as_me:$LINENO: error: unable to locate tkConfig.sh because no Tcl shell was found" >&5 -echo "$as_me: error: unable to locate tkConfig.sh because no Tcl shell was found" >&2;} - { (exit 1); exit 1; }; } - set X `echo 'puts $auto_path' | $TCLSH`; shift - fi - - for pgac_dir do - if test -r "$pgac_dir/tkConfig.sh"; then - TK_CONFIG_SH=$pgac_dir/tkConfig.sh - break - fi - done -fi - -if test -z "$TK_CONFIG_SH"; then - echo "$as_me:$LINENO: result: no" >&5 -echo "${ECHO_T}no" >&6 - { { echo "$as_me:$LINENO: error: file 'tkConfig.sh' is required for Tk" >&5 -echo "$as_me: error: file 'tkConfig.sh' is required for Tk" >&2;} - { (exit 1); exit 1; }; } -else - echo "$as_me:$LINENO: result: $TK_CONFIG_SH" >&5 -echo "${ECHO_T}$TK_CONFIG_SH" >&6 -fi - - - - . "$TK_CONFIG_SH" -eval TK_LIBS=\"$TK_LIBS\" -eval TK_LIB_SPEC=\"$TK_LIB_SPEC\" -eval TK_XINCLUDES=\"$TK_XINCLUDES\" - -fi - - # # Check for DocBook and tools # @@ -18197,7 +18083,6 @@ s,@autodepend@,$autodepend,;t t s,@INCLUDES@,$INCLUDES,;t t s,@enable_thread_safety@,$enable_thread_safety,;t t s,@with_tcl@,$with_tcl,;t t -s,@with_tk@,$with_tk,;t t s,@with_perl@,$with_perl,;t t s,@with_python@,$with_python,;t t s,@with_krb4@,$with_krb4,;t t @@ -18253,10 +18138,6 @@ s,@TCL_LIBS@,$TCL_LIBS,;t t s,@TCL_LIB_SPEC@,$TCL_LIB_SPEC,;t t s,@TCL_SHARED_BUILD@,$TCL_SHARED_BUILD,;t t s,@TCL_SHLIB_LD_LIBS@,$TCL_SHLIB_LD_LIBS,;t t -s,@TK_CONFIG_SH@,$TK_CONFIG_SH,;t t -s,@TK_LIBS@,$TK_LIBS,;t t -s,@TK_LIB_SPEC@,$TK_LIB_SPEC,;t t -s,@TK_XINCLUDES@,$TK_XINCLUDES,;t t s,@NSGMLS@,$NSGMLS,;t t s,@JADE@,$JADE,;t t s,@have_docbook@,$have_docbook,;t t diff --git a/configure.in b/configure.in index 92756c5b95..92eed4d717 100644 --- a/configure.in +++ b/configure.in @@ -1,5 +1,5 @@ dnl Process this file with autoconf to produce a configure script. -dnl $PostgreSQL: pgsql/configure.in,v 1.322 2004/03/24 03:54:16 momjian Exp $ +dnl $PostgreSQL: pgsql/configure.in,v 1.323 2004/04/20 00:33:45 pgsql Exp $ dnl dnl Developers, please strive to achieve this order: dnl @@ -372,26 +372,10 @@ PGAC_ARG_BOOL(with, tcl, no, [ --with-tcl build Tcl and Tk interfa AC_MSG_RESULT([$with_tcl]) AC_SUBST([with_tcl]) -# If Tcl is enabled (above) then Tk is also, unless the user disables it using --without-tk -AC_MSG_CHECKING([whether to build with Tk]) -if test "$with_tcl" = yes; then - PGAC_ARG_BOOL(with, tk, yes, [ --without-tk do not build Tk interfaces if Tcl is enabled]) -else - with_tk=no -fi -AC_MSG_RESULT([$with_tk]) -AC_SUBST([with_tk]) - - # We see if the path to the Tcl/Tk configuration scripts is specified. # This will override the use of tclsh to find the paths to search. -PGAC_ARG_REQ(with, tclconfig, [ --with-tclconfig=DIR tclConfig.sh and tkConfig.sh are in DIR]) - -# We see if the path to the Tk configuration scripts is specified. -# This will override the use of tclsh to find the paths to search. - -PGAC_ARG_REQ(with, tkconfig, [ --with-tkconfig=DIR tkConfig.sh is in DIR]) +PGAC_ARG_REQ(with, tclconfig, [ --with-tclconfig=DIR tclConfig.sh is in DIR]) # # Optionally build Perl modules (PL/Perl) @@ -1189,13 +1173,6 @@ if test "$with_tcl" = yes; then AC_SUBST(TCL_SHLIB_LD_LIBS)dnl don't want to double-evaluate that one fi -# Check for Tk configuration script tkConfig.sh -if test "$with_tk" = yes; then - PGAC_PATH_TKCONFIGSH([$with_tkconfig $with_tclconfig]) - PGAC_EVAL_TCLCONFIGSH([$TK_CONFIG_SH], [TK_LIBS,TK_LIB_SPEC,TK_XINCLUDES]) -fi - - # # Check for DocBook and tools # diff --git a/src/Makefile.global.in b/src/Makefile.global.in index 11edf55210..5ce53ccb0b 100644 --- a/src/Makefile.global.in +++ b/src/Makefile.global.in @@ -1,5 +1,5 @@ # -*-makefile-*- -# $PostgreSQL: pgsql/src/Makefile.global.in,v 1.176 2004/03/10 21:12:46 momjian Exp $ +# $PostgreSQL: pgsql/src/Makefile.global.in,v 1.177 2004/04/20 00:33:46 pgsql Exp $ #------------------------------------------------------------------------------ # All PostgreSQL makefiles include this file and use the variables it sets, @@ -123,7 +123,6 @@ localedir := @localedir@ with_perl = @with_perl@ with_python = @with_python@ with_tcl = @with_tcl@ -with_tk = @with_tk@ enable_shared = @enable_shared@ enable_rpath = @enable_rpath@ enable_nls = @enable_nls@ diff --git a/src/bin/Makefile b/src/bin/Makefile index c2ebfc4903..abf6373bdc 100644 --- a/src/bin/Makefile +++ b/src/bin/Makefile @@ -5,7 +5,7 @@ # Portions Copyright (c) 1996-2002, PostgreSQL Global Development Group # Portions Copyright (c) 1994, Regents of the University of California # -# $PostgreSQL: pgsql/src/bin/Makefile,v 1.41 2003/12/17 18:44:08 petere Exp $ +# $PostgreSQL: pgsql/src/bin/Makefile,v 1.42 2004/04/20 00:33:47 pgsql Exp $ # #------------------------------------------------------------------------- @@ -17,10 +17,6 @@ DIRS := initdb initlocation ipcclean pg_ctl pg_dump \ psql scripts pg_config pg_controldata pg_resetxlog \ pg_encoding -ifeq ($(with_tcl), yes) - DIRS += pgtclsh -endif - all install installdirs uninstall depend distprep: @for dir in $(DIRS); do $(MAKE) -C $$dir $@ || exit; done diff --git a/src/bin/pgtclsh/Makefile b/src/bin/pgtclsh/Makefile deleted file mode 100644 index 96e3da2337..0000000000 --- a/src/bin/pgtclsh/Makefile +++ /dev/null @@ -1,58 +0,0 @@ -#------------------------------------------------------------------------- -# -# Makefile for src/bin/pgtclsh -# (a tclsh workalike with pgtcl commands installed) -# -# Portions Copyright (c) 1996-2002, PostgreSQL Global Development Group -# Portions Copyright (c) 1994, Regents of the University of California -# -# $PostgreSQL: pgsql/src/bin/pgtclsh/Makefile,v 1.43 2003/12/19 11:54:25 petere Exp $ -# -#------------------------------------------------------------------------- - -subdir = src/bin/pgtclsh -top_builddir = ../../.. -include $(top_builddir)/src/Makefile.global - - -libpgtcl_srcdir = $(top_srcdir)/src/interfaces/libpgtcl -libpgtcl_builddir = $(top_builddir)/src/interfaces/libpgtcl -libpgtcl = -L$(libpgtcl_builddir) -lpgtcl - -override CPPFLAGS := -I$(libpgtcl_srcdir) $(TK_XINCLUDES) $(TCL_INCLUDE_SPEC) $(CPPFLAGS) - - -# If we are here then Tcl is available -PROGRAMS = pgtclsh - -# Add Tk targets if Tk is available -ifeq ($(with_tk), yes) -PROGRAMS += pgtksh -endif - -all: submake $(PROGRAMS) - -pgtclsh: pgtclAppInit.o - $(CC) $(CFLAGS) $^ $(libpgtcl) $(libpq) $(TCL_LIB_SPEC) $(TCL_LIBS) $(LDFLAGS) $(LIBS) -o $@ - -pgtksh: pgtkAppInit.o - $(CC) $(CFLAGS) $^ $(libpgtcl) $(libpq) $(TK_LIB_SPEC) $(TK_LIBS) $(TCL_LIB_SPEC) $(LDFLAGS) $(LIBS) -o $@ - -.PHONY: submake -submake: - $(MAKE) -C $(libpgtcl_builddir) all - -install: all installdirs - $(INSTALL_PROGRAM) pgtclsh$(X) $(DESTDIR)$(bindir)/pgtclsh$(X) -ifeq ($(with_tk), yes) - $(INSTALL_PROGRAM) pgtksh$(X) $(DESTDIR)$(bindir)/pgtksh$(X) -endif - -installdirs: - $(mkinstalldirs) $(DESTDIR)$(bindir) - -uninstall: - rm -f $(DESTDIR)$(bindir)/pgtclsh$(X) $(DESTDIR)$(bindir)/pgtksh$(X) - -clean distclean maintainer-clean: - rm -f pgtclAppInit.o pgtkAppInit.o pgtclsh pgtksh diff --git a/src/bin/pgtclsh/README b/src/bin/pgtclsh/README deleted file mode 100644 index 618fdbaecc..0000000000 --- a/src/bin/pgtclsh/README +++ /dev/null @@ -1,10 +0,0 @@ -pgtclsh is an example of a tclsh extended with the new Tcl -commands provided by the libpgtcl library. By using pgtclsh, one can -write front-end applications to PostgreSQL in Tcl without having to -deal with any libpq programming at all. - -The pgtclsh is an enhanced version of tclsh. Similarly, pgtksh is a -wish replacement with PostgreSQL bindings. - -For details of the libpgtcl interface, please see the Programmer's -Guide. diff --git a/src/bin/pgtclsh/pgtclAppInit.c b/src/bin/pgtclsh/pgtclAppInit.c deleted file mode 100644 index 6092644c56..0000000000 --- a/src/bin/pgtclsh/pgtclAppInit.c +++ /dev/null @@ -1,112 +0,0 @@ -/* - * pgtclAppInit.c - * a skeletal Tcl_AppInit that provides pgtcl initialization - * to create a tclsh that can talk to pglite backends - * - * Portions Copyright (c) 1996-2003, PostgreSQL Global Development Group - * Portions Copyright (c) 1993 The Regents of the University of California. - * Copyright (c) 1994 Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - */ - -#include - -#include "libpgtcl.h" - -/* - * The following variable is a special hack that is needed in order for - * Sun shared libraries to be used for Tcl. - */ - -#ifdef NEED_MATHERR -extern int matherr(); -int *tclDummyMathPtr = (int *) matherr; -#endif - - -/* - *---------------------------------------------------------------------- - * - * main - * - * This is the main program for the application. - * - * Results: - * None: Tcl_Main never returns here, so this procedure never - * returns either. - * - * Side effects: - * Whatever the application does. - * - *---------------------------------------------------------------------- - */ - -int -main(int argc, char **argv) -{ - Tcl_Main(argc, argv, Tcl_AppInit); - return 0; /* Needed only to prevent compiler - * warning. */ -} - - -/* - *---------------------------------------------------------------------- - * - * Tcl_AppInit - * - * This procedure performs application-specific initialization. - * Most applications, especially those that incorporate additional - * packages, will have their own version of this procedure. - * - * Results: - * Returns a standard Tcl completion code, and leaves an error - * message in interp->result if an error occurs. - * - * Side effects: - * Depends on the startup script. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_AppInit(Tcl_Interp *interp) -{ - if (Tcl_Init(interp) == TCL_ERROR) - return TCL_ERROR; - - /* - * Call the init procedures for included packages. Each call should - * look like this: - * - * if (Mod_Init(interp) == TCL_ERROR) { return TCL_ERROR; } - * - * where "Mod" is the name of the module. - */ - - if (Pgtcl_Init(interp) == TCL_ERROR) - return TCL_ERROR; - - /* - * Call Tcl_CreateCommand for application-specific commands, if they - * weren't already created by the init procedures called above. - */ - - /* - * Specify a user-specific startup file to invoke if the application - * is run interactively. Typically the startup file is "~/.apprc" - * where "app" is the name of the application. If this line is - * deleted then no user-specific startup file will be run under any - * conditions. - */ - -#if (TCL_MAJOR_VERSION <= 7) && (TCL_MINOR_VERSION < 5) - tcl_RcFileName = "~/.tclshrc"; -#else - Tcl_SetVar(interp, "tcl_rcFileName", "~/.tclshrc", TCL_GLOBAL_ONLY); -#endif - - return TCL_OK; -} diff --git a/src/bin/pgtclsh/pgtclUtils.tcl b/src/bin/pgtclsh/pgtclUtils.tcl deleted file mode 100644 index e09e8b2b3a..0000000000 --- a/src/bin/pgtclsh/pgtclUtils.tcl +++ /dev/null @@ -1,17 +0,0 @@ -# getDBs : -# get the names of all the databases at a given host and port number -# with the defaults being the localhost and port 5432 -# return them in alphabetical order -proc getDBs { {host "localhost"} {port "5432"} } { - # datnames is the list to be result - set conn [pg_connect template1 -host $host -port $port] - set res [pg_exec $conn "SELECT datname FROM pg_database ORDER BY datname"] - set ntups [pg_result $res -numTuples] - for {set i 0} {$i < $ntups} {incr i} { - lappend datnames [pg_result $res -getTuple $i] - } - pg_result $res -clear - pg_disconnect $conn - return $datnames -} - diff --git a/src/bin/pgtclsh/pgtkAppInit.c b/src/bin/pgtclsh/pgtkAppInit.c deleted file mode 100644 index 23f25777e6..0000000000 --- a/src/bin/pgtclsh/pgtkAppInit.c +++ /dev/null @@ -1,114 +0,0 @@ -/* - * pgtkAppInit.c - * - * a skeletal Tcl_AppInit that provides pgtcl initialization - * to create a tclsh that can talk to pglite backends - * - * Portions Copyright (c) 1996-2003, PostgreSQL Global Development Group - * Portions Copyright (c) 1993 The Regents of the University of California. - * Copyright (c) 1994 Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - */ - -#include -#include "libpgtcl.h" - -/* - * The following variable is a special hack that is needed in order for - * Sun shared libraries to be used for Tcl. - */ - -#ifdef NEED_MATHERR -extern int matherr(); -int *tclDummyMathPtr = (int *) matherr; -#endif - - -/* - *---------------------------------------------------------------------- - * - * main - * - * This is the main program for the application. - * - * Results: - * None: Tk_Main never returns here, so this procedure never - * returns either. - * - * Side effects: - * Whatever the application does. - * - *---------------------------------------------------------------------- - */ - -int -main(int argc, char **argv) -{ - Tk_Main(argc, argv, Tcl_AppInit); - return 0; /* Needed only to prevent compiler - * warning. */ -} - - -/* - *---------------------------------------------------------------------- - * - * Tcl_AppInit - * - * This procedure performs application-specific initialization. - * Most applications, especially those that incorporate additional - * packages, will have their own version of this procedure. - * - * Results: - * Returns a standard Tcl completion code, and leaves an error - * message in interp->result if an error occurs. - * - * Side effects: - * Depends on the startup script. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_AppInit(Tcl_Interp *interp) -{ - if (Tcl_Init(interp) == TCL_ERROR) - return TCL_ERROR; - if (Tk_Init(interp) == TCL_ERROR) - return TCL_ERROR; - - /* - * Call the init procedures for included packages. Each call should - * look like this: - * - * if (Mod_Init(interp) == TCL_ERROR) { return TCL_ERROR; } - * - * where "Mod" is the name of the module. - */ - - if (Pgtcl_Init(interp) == TCL_ERROR) - return TCL_ERROR; - - /* - * Call Tcl_CreateCommand for application-specific commands, if they - * weren't already created by the init procedures called above. - */ - - /* - * Specify a user-specific startup file to invoke if the application - * is run interactively. Typically the startup file is "~/.apprc" - * where "app" is the name of the application. If this line is - * deleted then no user-specific startup file will be run under any - * conditions. - */ - -#if (TCL_MAJOR_VERSION <= 7) && (TCL_MINOR_VERSION < 5) - tcl_RcFileName = "~/.wishrc"; -#else - Tcl_SetVar(interp, "tcl_rcFileName", "~/.wishrc", TCL_GLOBAL_ONLY); -#endif - - return TCL_OK; -} diff --git a/src/bin/pgtclsh/updateStats.tcl b/src/bin/pgtclsh/updateStats.tcl deleted file mode 100644 index 9cb8384dc2..0000000000 --- a/src/bin/pgtclsh/updateStats.tcl +++ /dev/null @@ -1,71 +0,0 @@ -# -# updateStats -# updates the statistic of number of distinct attribute values -# (this should really be done by the vacuum command) -# this is kind of brute force and slow, but it works -# since we use SELECT DISTINCT to calculate the number of distinct values -# and that does a sort, you need to have plenty of disk space for the -# intermediate sort files. -# -# - jolly 6/8/95 - -# -# update_attnvals -# takes in a table and updates the attnvals columns for the attributes -# of that table -# -# conn is the database connection -# rel is the table name -proc update_attnvals {conn rel} { - - # first, get the oid of the rel - set res [pg_exec $conn "SELECT oid FROM pg_class where relname = '$rel'"] - if { [pg_result $res -numTuples] == "0"} { - puts stderr "update_attnvals: Relation named $rel was not found" - return - } - set oid [pg_result $res -getTuple 0] - pg_result $res -clear - - # use this query to find the names of the attributes - set res [pg_exec $conn "SELECT * FROM $rel WHERE 'f'::bool"] - set attrNames [pg_result $res -attributes] - - puts "attrNames = $attrNames" - foreach att $attrNames { - # find how many distinct values there are for this attribute - # this may fail if the user-defined type doesn't have - # comparison operators defined - set res2 [pg_exec $conn "SELECT DISTINCT $att FROM $rel"] - set NVALS($att) [pg_result $res2 -numTuples] - puts "NVALS($att) is $NVALS($att)" - pg_result $res2 -clear - } - pg_result $res -clear - - # now, update the pg_attribute table - foreach att $attrNames { - # first find the oid of the row to change - set res [pg_exec $conn "SELECT oid FROM pg_attribute a WHERE a.attname = '$att' and a.attrelid = '$oid'"] - set attoid [pg_result $res -getTuple 0] - set res2 [pg_exec $conn "UPDATE pg_attribute SET attnvals = $NVALS($att) where pg_attribute.oid = '$attoid'::oid"] - } -} - -# updateStats -# takes in a database name -# and updates the attnval stat for all the user-defined tables -# in the database -proc updateStats { dbName } { - # datnames is the list to be result - set conn [pg_connect $dbName] - set res [pg_exec $conn "SELECT relname FROM pg_class WHERE relkind = 'r' and relname !~ '^pg_'"] - set ntups [pg_result $res -numTuples] - for {set i 0} {$i < $ntups} {incr i} { - set rel [pg_result $res -getTuple $i] - puts "updating attnvals stats on table $rel" - update_attnvals $conn $rel - } - pg_disconnect $conn -} - diff --git a/src/interfaces/Makefile b/src/interfaces/Makefile index 1fa91d5375..876c489ecb 100644 --- a/src/interfaces/Makefile +++ b/src/interfaces/Makefile @@ -4,7 +4,7 @@ # # Copyright (c) 1994, Regents of the University of California # -# $PostgreSQL: pgsql/src/interfaces/Makefile,v 1.52 2004/01/19 21:20:06 tgl Exp $ +# $PostgreSQL: pgsql/src/interfaces/Makefile,v 1.53 2004/04/20 00:33:51 pgsql Exp $ # #------------------------------------------------------------------------- @@ -14,12 +14,7 @@ include $(top_builddir)/src/Makefile.global DIRS := libpq ecpg -ALLDIRS := $(DIRS) libpgtcl - -ifeq ($(with_tcl), yes) -DIRS += libpgtcl -endif - +ALLDIRS := $(DIRS) all install installdirs uninstall dep depend distprep: @for dir in $(DIRS); do $(MAKE) -C $$dir $@ || exit; done diff --git a/src/interfaces/libpgtcl/Makefile b/src/interfaces/libpgtcl/Makefile deleted file mode 100644 index cff31dab5b..0000000000 --- a/src/interfaces/libpgtcl/Makefile +++ /dev/null @@ -1,51 +0,0 @@ -#------------------------------------------------------------------------- -# -# Makefile for libpgtcl library -# -# Copyright (c) 1994, Regents of the University of California -# -# $PostgreSQL: pgsql/src/interfaces/libpgtcl/Makefile,v 1.36 2004/02/10 07:26:25 tgl Exp $ -# -#------------------------------------------------------------------------- - -subdir = src/interfaces/libpgtcl -top_builddir = ../../.. -include ../../Makefile.global - -NAME= pgtcl -SO_MAJOR_VERSION= 2 -SO_MINOR_VERSION= 5 - -override CPPFLAGS := -I$(libpq_srcdir) $(CPPFLAGS) $(TCL_INCLUDE_SPEC) - -OBJS= pgtcl.o pgtclCmds.o pgtclId.o - -SHLIB_LINK = $(libpq) $(TCL_LIB_SPEC) $(TCL_LIBS) \ - $(filter -lintl -lssl -lcrypto -lkrb5 -lcrypt, $(LIBS)) $(THREAD_LIBS) - -all: submake-libpq all-lib - -# Shared library stuff -include $(top_srcdir)/src/Makefile.shlib - -install: all installdirs install-headers install-lib - -.PHONY: install-headers -install-headers: libpgtcl.h - $(INSTALL_DATA) $< $(DESTDIR)$(includedir)/libpgtcl.h - -installdirs: - $(mkinstalldirs) $(DESTDIR)$(libdir) $(DESTDIR)$(includedir) - -uninstall: uninstall-lib - rm -f $(DESTDIR)$(includedir)/libpgtcl.h - -clean distclean maintainer-clean: clean-lib - rm -f $(OBJS) - -depend dep: - $(CC) -MM $(CFLAGS) *.c >depend - -ifeq (depend,$(wildcard depend)) -include depend -endif diff --git a/src/interfaces/libpgtcl/README b/src/interfaces/libpgtcl/README deleted file mode 100644 index c672405955..0000000000 --- a/src/interfaces/libpgtcl/README +++ /dev/null @@ -1,38 +0,0 @@ -libpgtcl is a library that implements Tcl commands for front-end -clients to interact with the Postgresql 6.3 (and perhaps later) -backends. See libpgtcl.doc for details. - -For an example of how to build a new tclsh to use libpgtcl, see the -directory ../bin/pgtclsh - -Note this version is modified by NeoSoft to have the following additional -features: - -1. Postgres connections are a valid Tcl channel, and can therefore - be manipulated by the interp command (ie. shared or transfered). - A connection handle's results are transfered/shared with it. - (Result handles are NOT channels, though it was tempting). Note - that a "close $connection" is now functionally identical to a - "pg_disconnect $connection", although pg_connect must be used - to create a connection. - -2. Result handles are changed in format: ${connection}.. - This just means for a connection 'pgtcl0', they look like pgtcl0.0, - pgtcl0.1, etc. Enforcing this syntax makes it easy to look up - the real pointer by indexing into an array associated with the - connection. - -3. I/O routines are now defined for the connection handle. I/O to/from - the connection is only valid under certain circumstances: following - the execution of the queries "copy from stdin" or - "copy
to stdout". In these cases, the result handle obtains - an intermediate status of "PGRES_COPY_IN" or "PGRES_COPY_OUT". The - programmer is then expected to use Tcl gets or read commands on the - database connection (not the result handle) to extract the copy data. - For copy outs, read until the standard EOF indication is encountered. - For copy ins, puts a single terminator (\.). The statement for this - would be - puts $conn "\\." or puts $conn {\.} - In either case (upon detecting the EOF or putting the `\.', the status - of the result handle will change to "PGRES_COMMAND_OK", and any further - I/O attempts will cause a Tcl error. diff --git a/src/interfaces/libpgtcl/libpgtcl.def b/src/interfaces/libpgtcl/libpgtcl.def deleted file mode 100644 index c4b45f2b61..0000000000 --- a/src/interfaces/libpgtcl/libpgtcl.def +++ /dev/null @@ -1,8 +0,0 @@ -;libpgtcl.def -; The LIBRARY entry must be same as the name of your DLL, the name of -; our DLL is libpgtcl.dll -LIBRARY libpgtcl -EXPORTS - - Pgtcl_Init - Pgtcl_SafeInit diff --git a/src/interfaces/libpgtcl/libpgtcl.h b/src/interfaces/libpgtcl/libpgtcl.h deleted file mode 100644 index a17313781c..0000000000 --- a/src/interfaces/libpgtcl/libpgtcl.h +++ /dev/null @@ -1,24 +0,0 @@ -/*------------------------------------------------------------------------- - * - * libpgtcl.h - * - * libpgtcl is a tcl package for front-ends to interface with PostgreSQL. - * It's a Tcl wrapper for libpq. - * - * Portions Copyright (c) 1996-2003, PostgreSQL Global Development Group - * Portions Copyright (c) 1994, Regents of the University of California - * - * $PostgreSQL: pgsql/src/interfaces/libpgtcl/libpgtcl.h,v 1.17 2003/11/29 22:41:25 pgsql Exp $ - * - *------------------------------------------------------------------------- - */ - -#ifndef LIBPGTCL_H -#define LIBPGTCL_H - -#include - -extern int Pgtcl_Init(Tcl_Interp *interp); -extern int Pgtcl_SafeInit(Tcl_Interp *interp); - -#endif /* LIBPGTCL_H */ diff --git a/src/interfaces/libpgtcl/pgtcl.c b/src/interfaces/libpgtcl/pgtcl.c deleted file mode 100644 index a9dc10e27a..0000000000 --- a/src/interfaces/libpgtcl/pgtcl.c +++ /dev/null @@ -1,170 +0,0 @@ -/*------------------------------------------------------------------------- - * - * pgtcl.c - * - * libpgtcl is a tcl package for front-ends to interface with PostgreSQL. - * It's a Tcl wrapper for libpq. - * - * Portions Copyright (c) 1996-2003, PostgreSQL Global Development Group - * Portions Copyright (c) 1994, Regents of the University of California - * - * - * IDENTIFICATION - * $PostgreSQL: pgsql/src/interfaces/libpgtcl/pgtcl.c,v 1.31 2004/02/02 00:35:08 neilc Exp $ - * - *------------------------------------------------------------------------- - */ - -#include "postgres_fe.h" -#include "libpgtcl.h" -#include "pgtclCmds.h" -#include "pgtclId.h" - -/* - * Pgtcl_Init - * initialization package for the PGTCL Tcl package - * - */ - -int -Pgtcl_Init(Tcl_Interp *interp) -{ - double tclversion; - - /* - * finish off the ChannelType struct. Much easier to do it here then - * to guess where it might be by position in the struct. This is - * needed for Tcl7.6 *only*, which has the getfileproc. - */ -#if HAVE_TCL_GETFILEPROC - Pg_ConnType.getFileProc = PgGetFileProc; -#endif - - /* - * Tcl versions >= 8.1 use UTF-8 for their internal string - * representation. Therefore PGCLIENTENCODING must be set to UNICODE - * for these versions. - */ - Tcl_GetDouble(interp, Tcl_GetVar(interp, "tcl_version", TCL_GLOBAL_ONLY), &tclversion); - if (tclversion >= 8.1) - Tcl_PutEnv("PGCLIENTENCODING=UNICODE"); - - /* register all pgtcl commands */ - Tcl_CreateCommand(interp, - "pg_conndefaults", - Pg_conndefaults, - NULL, NULL); - - Tcl_CreateCommand(interp, - "pg_connect", - Pg_connect, - NULL, NULL); - - Tcl_CreateCommand(interp, - "pg_disconnect", - Pg_disconnect, - NULL, NULL); - - Tcl_CreateCommand(interp, - "pg_exec", - Pg_exec, - NULL, NULL); - - Tcl_CreateCommand(interp, - "pg_select", - Pg_select, - NULL, NULL); - - Tcl_CreateCommand(interp, - "pg_result", - Pg_result, - NULL, NULL); - - Tcl_CreateCommand(interp, - "pg_execute", - Pg_execute, - NULL, NULL); - - Tcl_CreateCommand(interp, - "pg_lo_open", - Pg_lo_open, - NULL, NULL); - - Tcl_CreateCommand(interp, - "pg_lo_close", - Pg_lo_close, - NULL, NULL); - -#ifdef PGTCL_USE_TCLOBJ - Tcl_CreateObjCommand(interp, - "pg_lo_read", - Pg_lo_read, - NULL, NULL); - - Tcl_CreateObjCommand(interp, - "pg_lo_write", - Pg_lo_write, - NULL, NULL); -#else - Tcl_CreateCommand(interp, - "pg_lo_read", - Pg_lo_read, - NULL, NULL); - - Tcl_CreateCommand(interp, - "pg_lo_write", - Pg_lo_write, - NULL, NULL); -#endif - - Tcl_CreateCommand(interp, - "pg_lo_lseek", - Pg_lo_lseek, - NULL, NULL); - - Tcl_CreateCommand(interp, - "pg_lo_creat", - Pg_lo_creat, - NULL, NULL); - - Tcl_CreateCommand(interp, - "pg_lo_tell", - Pg_lo_tell, - NULL, NULL); - - Tcl_CreateCommand(interp, - "pg_lo_unlink", - Pg_lo_unlink, - NULL, NULL); - - Tcl_CreateCommand(interp, - "pg_lo_import", - Pg_lo_import, - NULL, NULL); - - Tcl_CreateCommand(interp, - "pg_lo_export", - Pg_lo_export, - NULL, NULL); - - Tcl_CreateCommand(interp, - "pg_listen", - Pg_listen, - NULL, NULL); - - Tcl_CreateCommand(interp, - "pg_on_connection_loss", - Pg_on_connection_loss, - NULL, NULL); - - Tcl_PkgProvide(interp, "Pgtcl", "1.4"); - - return TCL_OK; -} - - -int -Pgtcl_SafeInit(Tcl_Interp *interp) -{ - return Pgtcl_Init(interp); -} diff --git a/src/interfaces/libpgtcl/pgtclCmds.c b/src/interfaces/libpgtcl/pgtclCmds.c deleted file mode 100644 index bbd0064bf9..0000000000 --- a/src/interfaces/libpgtcl/pgtclCmds.c +++ /dev/null @@ -1,2081 +0,0 @@ -/*------------------------------------------------------------------------- - * - * pgtclCmds.c - * C functions which implement pg_* tcl commands - * - * Portions Copyright (c) 1996-2003, PostgreSQL Global Development Group - * Portions Copyright (c) 1994, Regents of the University of California - * - * - * IDENTIFICATION - * $PostgreSQL: pgsql/src/interfaces/libpgtcl/pgtclCmds.c,v 1.77 2004/01/07 18:56:29 neilc Exp $ - * - *------------------------------------------------------------------------- - */ -#include "postgres_fe.h" - -#include - -#include "pgtclCmds.h" -#include "pgtclId.h" -#include "libpq/libpq-fs.h" /* large-object interface */ - -/* - * Local function forward declarations - */ -static int execute_put_values(Tcl_Interp *interp, CONST84 char *array_varname, - PGresult *result, int tupno); - - -#ifdef TCL_ARRAYS - -#define ISOCTAL(c) (((c) >= '0') && ((c) <= '7')) -#define DIGIT(c) ((c) - '0') - - -/* - * translate_escape() - * - * This function performs in-place translation of a single C-style - * escape sequence pointed by p. Curly braces { } and double-quote - * are left escaped if they appear inside an array. - * The value returned is the pointer to the last character (the one - * just before the rest of the buffer). - */ - -static inline char * -translate_escape(char *p, int isArray) -{ - char c, - *q, - *s; - -#ifdef TCL_ARRAYS_DEBUG_ESCAPE - printf(" escape = '%s'\n", p); -#endif - /* Address of the first character after the escape sequence */ - s = p + 2; - switch (c = *(p + 1)) - { - case '0': - case '1': - case '2': - case '3': - case '4': - case '5': - case '6': - case '7': - c = DIGIT(c); - if (ISOCTAL(*s)) - c = (c << 3) + DIGIT(*s++); - if (ISOCTAL(*s)) - c = (c << 3) + DIGIT(*s++); - *p = c; - break; - case 'b': - *p = '\b'; - break; - case 'f': - *p = '\f'; - break; - case 'n': - *p = '\n'; - break; - case 'r': - *p = '\r'; - break; - case 't': - *p = '\t'; - break; - case 'v': - *p = '\v'; - break; - case '\\': - case '{': - case '}': - case '"': - - /* - * Backslahes, curly braces and double-quotes are left escaped - * if they appear inside an array. They will be unescaped by - * Tcl in Tcl_AppendElement. The buffer position is advanced - * by 1 so that the this character is not processed again by - * the caller. - */ - if (isArray) - return p + 1; - else - *p = c; - break; - case '\0': - - /* - * This means a backslash at the end of the string. It should - * never happen but in that case replace the \ with a \0 but - * don't shift the rest of the buffer so that the caller can - * see the end of the string and terminate. - */ - *p = c; - return p; - break; - default: - - /* - * Default case, store the escaped character over the - * backslash and shift the buffer over itself. - */ - *p = c; - } - /* Shift the rest of the buffer over itself after the current char */ - q = p + 1; - for (; *s;) - *q++ = *s++; - *q = '\0'; -#ifdef TCL_ARRAYS_DEBUG_ESCAPE - printf(" after = '%s'\n", p); -#endif - return p; -} - -/* - * tcl_value() - * - * This function does in-line conversion of a value returned by libpq - * into a tcl string or into a tcl list if the value looks like the - * representation of a postgres array. - */ - -static char * -tcl_value(char *value) -{ - int literal, - last; - char *p; - - if (!value) - return NULL; - -#ifdef TCL_ARRAYS_DEBUG - printf("pq_value = '%s'\n", value); -#endif - last = strlen(value) - 1; - if ((last >= 1) && (value[0] == '{') && (value[last] == '}')) - { - /* Looks like an array, replace ',' with spaces */ - /* Remove the outer pair of { }, the last first! */ - value[last] = '\0'; - value++; - literal = 0; - for (p = value; *p; p++) - { - if (!literal) - { - /* We are at the list level, look for ',' and '"' */ - switch (*p) - { - case '"': /* beginning of literal */ - literal = 1; - break; - case ',': /* replace the ',' with space */ - *p = ' '; - break; - } - } - else - { - /* We are inside a C string */ - switch (*p) - { - case '"': /* end of literal */ - literal = 0; - break; - case '\\': - - /* - * escape sequence, translate it - */ - p = translate_escape(p, 1); - break; - } - } - if (!*p) - break; - } - } - else - { - /* Looks like a normal scalar value */ - for (p = value; *p; p++) - { - if (*p == '\\') - { - /* - * escape sequence, translate it - */ - p = translate_escape(p, 0); - } - if (!*p) - break; - } - } -#ifdef TCL_ARRAYS_DEBUG - printf("tcl_value = '%s'\n\n", value); -#endif - return value; -} -#endif /* TCL_ARRAYS */ - - -/********************************** - * pg_conndefaults - - syntax: - pg_conndefaults - - the return result is a list describing the possible options and their - current default values for a call to pg_connect with the new -conninfo - syntax. Each entry in the list is a sublist of the format: - - {optname label dispchar dispsize value} - - **********************************/ - -int -Pg_conndefaults(ClientData cData, Tcl_Interp *interp, int argc, CONST84 char *argv[]) -{ - PQconninfoOption *options = PQconndefaults(); - PQconninfoOption *option; - Tcl_DString result; - char ibuf[32]; - - if (options) - { - Tcl_DStringInit(&result); - - for (option = options; option->keyword != NULL; option++) - { - char *val = option->val ? option->val : ""; - - sprintf(ibuf, "%d", option->dispsize); - Tcl_DStringStartSublist(&result); - Tcl_DStringAppendElement(&result, option->keyword); - Tcl_DStringAppendElement(&result, option->label); - Tcl_DStringAppendElement(&result, option->dispchar); - Tcl_DStringAppendElement(&result, ibuf); - Tcl_DStringAppendElement(&result, val); - Tcl_DStringEndSublist(&result); - } - Tcl_DStringResult(interp, &result); - - PQconninfoFree(options); - } - - return TCL_OK; -} - - -/********************************** - * pg_connect - make a connection to a backend. - - syntax: - pg_connect dbName [-host hostName] [-port portNumber] [-tty pqtty]] - - the return result is either an error message or a handle for a database - connection. Handles start with the prefix "pgp" - - **********************************/ - -int -Pg_connect(ClientData cData, Tcl_Interp *interp, int argc, CONST84 char *argv[]) -{ - const char *pghost = NULL; - const char *pgtty = NULL; - const char *pgport = NULL; - const char *pgoptions = NULL; - const char *dbName; - int i; - PGconn *conn; - - if (argc == 1) - { - Tcl_AppendResult(interp, "pg_connect: database name missing\n", 0); - Tcl_AppendResult(interp, "pg_connect databaseName [-host hostName] [-port portNumber] [-tty pgtty]\n", 0); - Tcl_AppendResult(interp, "pg_connect -conninfo conninfoString", 0); - return TCL_ERROR; - - } - - if (!strcmp("-conninfo", argv[1])) - { - /* - * Establish a connection using the new PQconnectdb() interface - */ - if (argc != 3) - { - Tcl_AppendResult(interp, "pg_connect: syntax error\n", 0); - Tcl_AppendResult(interp, "pg_connect -conninfo conninfoString", 0); - return TCL_ERROR; - } - conn = PQconnectdb(argv[2]); - } - else - { - /* - * Establish a connection using the old PQsetdb() interface - */ - if (argc > 2) - { - /* parse for pg environment settings */ - i = 2; - while (i + 1 < argc) - { - if (strcmp(argv[i], "-host") == 0) - { - pghost = argv[i + 1]; - i += 2; - } - else if (strcmp(argv[i], "-port") == 0) - { - pgport = argv[i + 1]; - i += 2; - } - else if (strcmp(argv[i], "-tty") == 0) - { - pgtty = argv[i + 1]; - i += 2; - } - else if (strcmp(argv[i], "-options") == 0) - { - pgoptions = argv[i + 1]; - i += 2; - } - else - { - Tcl_AppendResult(interp, "Bad option to pg_connect: ", - argv[i], 0); - Tcl_AppendResult(interp, "\npg_connect databaseName [-host hostName] [-port portNumber] [-tty pgtty]", 0); - return TCL_ERROR; - } - } /* while */ - if ((i % 2 != 0) || i != argc) - { - Tcl_AppendResult(interp, "wrong # of arguments to pg_connect: ", - argv[i], 0); - Tcl_AppendResult(interp, "\npg_connect databaseName [-host hostName] [-port portNumber] [-tty pgtty]", 0); - return TCL_ERROR; - } - } - dbName = argv[1]; - conn = PQsetdb(pghost, pgport, pgoptions, pgtty, dbName); - } - - if (PQstatus(conn) == CONNECTION_OK) - { - PgSetConnectionId(interp, conn); - return TCL_OK; - } - else - { - Tcl_AppendResult(interp, "Connection to database failed\n", - PQerrorMessage(conn), 0); - PQfinish(conn); - return TCL_ERROR; - } -} - - -/********************************** - * pg_disconnect - close a backend connection - - syntax: - pg_disconnect connection - - The argument passed in must be a connection pointer. - - **********************************/ - -int -Pg_disconnect(ClientData cData, Tcl_Interp *interp, int argc, CONST84 char *argv[]) -{ - PGconn *conn; - Tcl_Channel conn_chan; - - if (argc != 2) - { - Tcl_AppendResult(interp, "Wrong # of arguments\n", "pg_disconnect connection", 0); - return TCL_ERROR; - } - - conn_chan = Tcl_GetChannel(interp, argv[1], 0); - if (conn_chan == NULL) - { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, argv[1], " is not a valid connection", 0); - return TCL_ERROR; - } - - /* Check that it is a PG connection and not something else */ - conn = PgGetConnectionId(interp, argv[1], NULL); - if (conn == NULL) - return TCL_ERROR; - - return Tcl_UnregisterChannel(interp, conn_chan); -} - -/********************************** - * pg_exec - send a query string to the backend connection - - syntax: - pg_exec connection query - - the return result is either an error message or a handle for a query - result. Handles start with the prefix "pgp" - **********************************/ - -int -Pg_exec(ClientData cData, Tcl_Interp *interp, int argc, CONST84 char *argv[]) -{ - Pg_ConnectionId *connid; - PGconn *conn; - PGresult *result; - - if (argc != 3) - { - Tcl_AppendResult(interp, "Wrong # of arguments\n", - "pg_exec connection queryString", 0); - return TCL_ERROR; - } - - conn = PgGetConnectionId(interp, argv[1], &connid); - if (conn == NULL) - return TCL_ERROR; - - if (connid->res_copyStatus != RES_COPY_NONE) - { - Tcl_SetResult(interp, "Attempt to query while COPY in progress", TCL_STATIC); - return TCL_ERROR; - } - - result = PQexec(conn, argv[2]); - - /* Transfer any notify events from libpq to Tcl event queue. */ - PgNotifyTransferEvents(connid); - - if (result) - { - int rId = PgSetResultId(interp, argv[1], result); - - ExecStatusType rStat = PQresultStatus(result); - - if (rStat == PGRES_COPY_IN || rStat == PGRES_COPY_OUT) - { - connid->res_copyStatus = RES_COPY_INPROGRESS; - connid->res_copy = rId; - } - return TCL_OK; - } - else - { - /* error occurred during the query */ - Tcl_SetResult(interp, PQerrorMessage(conn), TCL_VOLATILE); - return TCL_ERROR; - } -} - -/********************************** - * pg_result - get information about the results of a query - - syntax: - - pg_result result ?option? - - the options are: - - -status the status of the result - - -error the error message, if the status indicates error; otherwise - an empty string - - -conn the connection that produced the result - - -oid if command was an INSERT, the OID of the inserted tuple - - -numTuples the number of tuples in the query - - -cmdTuples the number of tuples affected by the query - - -numAttrs returns the number of attributes returned by the query - - -assign arrayName - assign the results to an array, using subscripts of the form - (tupno,attributeName) - - -assignbyidx arrayName ?appendstr? - assign the results to an array using the first field's value - as a key. - All but the first field of each tuple are stored, using - subscripts of the form (field0value,attributeNameappendstr) - - -getTuple tupleNumber - returns the values of the tuple in a list - - -tupleArray tupleNumber arrayName - stores the values of the tuple in array arrayName, indexed - by the attributes returned - - -attributes - returns a list of the name/type pairs of the tuple attributes - - -lAttributes - returns a list of the {name type len} entries of the tuple - attributes - - -clear clear the result buffer. Do not reuse after this - - **********************************/ -int -Pg_result(ClientData cData, Tcl_Interp *interp, int argc, CONST84 char *argv[]) -{ - PGresult *result; - const char *opt; - int i; - int tupno; - CONST84 char *arrVar; - char nameBuffer[256]; - const char *appendstr; - - if (argc < 3 || argc > 5) - { - Tcl_AppendResult(interp, "Wrong # of arguments\n", 0); - goto Pg_result_errReturn; /* append help info */ - } - - result = PgGetResultId(interp, argv[1]); - if (result == NULL) - { - Tcl_AppendResult(interp, "\n", - argv[1], " is not a valid query result", 0); - return TCL_ERROR; - } - - opt = argv[2]; - - if (strcmp(opt, "-status") == 0) - { - Tcl_AppendResult(interp, PQresStatus(PQresultStatus(result)), 0); - return TCL_OK; - } - else if (strcmp(opt, "-error") == 0) - { - Tcl_SetResult(interp, (char *) PQresultErrorMessage(result), - TCL_STATIC); - return TCL_OK; - } - else if (strcmp(opt, "-conn") == 0) - return PgGetConnByResultId(interp, argv[1]); - else if (strcmp(opt, "-oid") == 0) - { - sprintf(interp->result, "%u", PQoidValue(result)); - return TCL_OK; - } - else if (strcmp(opt, "-clear") == 0) - { - PgDelResultId(interp, argv[1]); - PQclear(result); - return TCL_OK; - } - else if (strcmp(opt, "-numTuples") == 0) - { - sprintf(interp->result, "%d", PQntuples(result)); - return TCL_OK; - } - else if (strcmp(opt, "-cmdTuples") == 0) - { - sprintf(interp->result, "%s", PQcmdTuples(result)); - return TCL_OK; - } - else if (strcmp(opt, "-numAttrs") == 0) - { - sprintf(interp->result, "%d", PQnfields(result)); - return TCL_OK; - } - else if (strcmp(opt, "-assign") == 0) - { - if (argc != 4) - { - Tcl_AppendResult(interp, "-assign option must be followed by a variable name", 0); - return TCL_ERROR; - } - arrVar = argv[3]; - - /* - * this assignment assigns the table of result tuples into a giant - * array with the name given in the argument. The indices of the - * array are of the form (tupno,attrName). Note we expect field - * names not to exceed a few dozen characters, so truncating to - * prevent buffer overflow shouldn't be a problem. - */ - for (tupno = 0; tupno < PQntuples(result); tupno++) - { - for (i = 0; i < PQnfields(result); i++) - { - sprintf(nameBuffer, "%d,%.200s", tupno, PQfname(result, i)); - if (Tcl_SetVar2(interp, arrVar, nameBuffer, -#ifdef TCL_ARRAYS - tcl_value(PQgetvalue(result, tupno, i)), -#else - PQgetvalue(result, tupno, i), -#endif - TCL_LEAVE_ERR_MSG) == NULL) - return TCL_ERROR; - } - } - Tcl_AppendResult(interp, arrVar, 0); - return TCL_OK; - } - else if (strcmp(opt, "-assignbyidx") == 0) - { - if (argc != 4 && argc != 5) - { - Tcl_AppendResult(interp, "-assignbyidx option requires an array name and optionally an append string", 0); - return TCL_ERROR; - } - arrVar = argv[3]; - appendstr = (argc == 5) ? (const char *) argv[4] : ""; - - /* - * this assignment assigns the table of result tuples into a giant - * array with the name given in the argument. The indices of the - * array are of the form (field0Value,attrNameappendstr). Here, we - * still assume PQfname won't exceed 200 characters, but we dare - * not make the same assumption about the data in field 0 nor the - * append string. - */ - for (tupno = 0; tupno < PQntuples(result); tupno++) - { - const char *field0 = -#ifdef TCL_ARRAYS - tcl_value(PQgetvalue(result, tupno, 0)); - -#else - PQgetvalue(result, tupno, 0); -#endif - char *workspace = malloc(strlen(field0) + strlen(appendstr) + 210); - - for (i = 1; i < PQnfields(result); i++) - { - sprintf(workspace, "%s,%.200s%s", field0, PQfname(result, i), - appendstr); - if (Tcl_SetVar2(interp, arrVar, workspace, -#ifdef TCL_ARRAYS - tcl_value(PQgetvalue(result, tupno, i)), -#else - PQgetvalue(result, tupno, i), -#endif - TCL_LEAVE_ERR_MSG) == NULL) - { - free(workspace); - return TCL_ERROR; - } - } - free(workspace); - } - Tcl_AppendResult(interp, arrVar, 0); - return TCL_OK; - } - else if (strcmp(opt, "-getTuple") == 0) - { - if (argc != 4) - { - Tcl_AppendResult(interp, "-getTuple option must be followed by a tuple number", 0); - return TCL_ERROR; - } - tupno = atoi(argv[3]); - if (tupno < 0 || tupno >= PQntuples(result)) - { - Tcl_AppendResult(interp, "argument to getTuple cannot exceed number of tuples - 1", 0); - return TCL_ERROR; - } -#ifdef TCL_ARRAYS - for (i = 0; i < PQnfields(result); i++) - Tcl_AppendElement(interp, tcl_value(PQgetvalue(result, tupno, i))); -#else - for (i = 0; i < PQnfields(result); i++) - Tcl_AppendElement(interp, PQgetvalue(result, tupno, i)); -#endif - return TCL_OK; - } - else if (strcmp(opt, "-tupleArray") == 0) - { - if (argc != 5) - { - Tcl_AppendResult(interp, "-tupleArray option must be followed by a tuple number and array name", 0); - return TCL_ERROR; - } - tupno = atoi(argv[3]); - if (tupno < 0 || tupno >= PQntuples(result)) - { - Tcl_AppendResult(interp, "argument to tupleArray cannot exceed number of tuples - 1", 0); - return TCL_ERROR; - } - for (i = 0; i < PQnfields(result); i++) - { - if (Tcl_SetVar2(interp, argv[4], PQfname(result, i), -#ifdef TCL_ARRAYS - tcl_value(PQgetvalue(result, tupno, i)), -#else - PQgetvalue(result, tupno, i), -#endif - TCL_LEAVE_ERR_MSG) == NULL) - return TCL_ERROR; - } - return TCL_OK; - } - else if (strcmp(opt, "-attributes") == 0) - { - for (i = 0; i < PQnfields(result); i++) - Tcl_AppendElement(interp, PQfname(result, i)); - return TCL_OK; - } - else if (strcmp(opt, "-lAttributes") == 0) - { - for (i = 0; i < PQnfields(result); i++) - { - /* start a sublist */ - if (i > 0) - Tcl_AppendResult(interp, " {", 0); - else - Tcl_AppendResult(interp, "{", 0); - Tcl_AppendElement(interp, PQfname(result, i)); - sprintf(nameBuffer, "%ld", (long) PQftype(result, i)); - Tcl_AppendElement(interp, nameBuffer); - sprintf(nameBuffer, "%ld", (long) PQfsize(result, i)); - Tcl_AppendElement(interp, nameBuffer); - /* end the sublist */ - Tcl_AppendResult(interp, "}", 0); - } - return TCL_OK; - } - else - { - Tcl_AppendResult(interp, "Invalid option\n", 0); - goto Pg_result_errReturn; /* append help info */ - } - - -Pg_result_errReturn: - Tcl_AppendResult(interp, - "pg_result result ?option? where option is\n", - "\t-status\n", - "\t-error\n", - "\t-conn\n", - "\t-oid\n", - "\t-numTuples\n", - "\t-cmdTuples\n", - "\t-numAttrs\n" - "\t-assign arrayVarName\n", - "\t-assignbyidx arrayVarName ?appendstr?\n", - "\t-getTuple tupleNumber\n", - "\t-tupleArray tupleNumber arrayVarName\n", - "\t-attributes\n" - "\t-lAttributes\n" - "\t-clear\n", - (char *) 0); - return TCL_ERROR; - - -} - - -/********************************** - * pg_execute - send a query string to the backend connection and process the result - - syntax: - pg_execute ?-array name? ?-oid varname? connection query ?loop_body? - - the return result is the number of tuples processed. If the query - returns tuples (i.e. a SELECT statement), the result is placed into - variables - **********************************/ - -int -Pg_execute(ClientData cData, Tcl_Interp *interp, int argc, CONST84 char *argv[]) -{ - Pg_ConnectionId *connid; - PGconn *conn; - PGresult *result; - int i; - int tupno; - int ntup; - int loop_rc; - CONST84 char *oid_varname = NULL; - CONST84 char *array_varname = NULL; - char buf[64]; - - char *usage = "Wrong # of arguments\n" - "pg_execute ?-array arrayname? ?-oid varname? " - "connection queryString ?loop_body?"; - - /* - * First we parse the options - */ - i = 1; - while (i < argc) - { - if (argv[i][0] != '-') - break; - - if (strcmp(argv[i], "-array") == 0) - { - /* - * The rows should appear in an array vs. to single variables - */ - i++; - if (i == argc) - { - Tcl_SetResult(interp, usage, TCL_VOLATILE); - return TCL_ERROR; - } - array_varname = argv[i++]; - continue; - } - - if (strcmp(argv[i], "-oid") == 0) - { - /* - * We should place PQoidValue() somewhere - */ - i++; - if (i == argc) - { - Tcl_SetResult(interp, usage, TCL_VOLATILE); - return TCL_ERROR; - } - oid_varname = argv[i++]; - continue; - } - - Tcl_AppendResult(interp, "Unknown option '", argv[i], "'", NULL); - return TCL_ERROR; - } - - /* - * Check that after option parsing at least 'connection' and 'query' - * are left - */ - if (argc - i < 2) - { - Tcl_SetResult(interp, usage, TCL_VOLATILE); - return TCL_ERROR; - } - - /* - * Get the connection and make sure no COPY command is pending - */ - conn = PgGetConnectionId(interp, argv[i++], &connid); - if (conn == NULL) - return TCL_ERROR; - - if (connid->res_copyStatus != RES_COPY_NONE) - { - Tcl_SetResult(interp, "Attempt to query while COPY in progress", TCL_STATIC); - return TCL_ERROR; - } - - /* - * Execute the query - */ - result = PQexec(conn, argv[i++]); - - /* - * Transfer any notify events from libpq to Tcl event queue. - */ - PgNotifyTransferEvents(connid); - - /* - * Check for errors - */ - if (result == NULL) - { - Tcl_SetResult(interp, PQerrorMessage(conn), TCL_VOLATILE); - return TCL_ERROR; - } - - /* - * Set the oid variable to the returned oid of an INSERT statement if - * requested (or 0 if it wasn't an INSERT) - */ - if (oid_varname != NULL) - { - char oid_buf[32]; - - sprintf(oid_buf, "%u", PQoidValue(result)); - if (Tcl_SetVar(interp, oid_varname, oid_buf, - TCL_LEAVE_ERR_MSG) == NULL) - { - PQclear(result); - return TCL_ERROR; - } - } - - /* - * Decide how to go on based on the result status - */ - switch (PQresultStatus(result)) - { - case PGRES_TUPLES_OK: - /* fall through if we have tuples */ - break; - - case PGRES_EMPTY_QUERY: - case PGRES_COMMAND_OK: - case PGRES_COPY_IN: - case PGRES_COPY_OUT: - /* tell the number of affected tuples for non-SELECT queries */ - Tcl_SetResult(interp, PQcmdTuples(result), TCL_VOLATILE); - PQclear(result); - return TCL_OK; - - default: - /* anything else must be an error */ - Tcl_ResetResult(interp); - Tcl_AppendElement(interp, PQresStatus(PQresultStatus(result))); - Tcl_AppendElement(interp, PQresultErrorMessage(result)); - PQclear(result); - return TCL_ERROR; - } - - /* - * We reach here only for queries that returned tuples - */ - if (i == argc) - { - /* - * We don't have a loop body. If we have at least one result row, - * we set all the variables to the first one and return. - */ - if (PQntuples(result) > 0) - { - if (execute_put_values(interp, array_varname, result, 0) != TCL_OK) - { - PQclear(result); - return TCL_ERROR; - } - } - - sprintf(buf, "%d", PQntuples(result)); - Tcl_SetResult(interp, buf, TCL_VOLATILE); - PQclear(result); - return TCL_OK; - } - - /* - * We have a loop body. For each row in the result set put the values - * into the Tcl variables and execute the body. - */ - ntup = PQntuples(result); - for (tupno = 0; tupno < ntup; tupno++) - { - if (execute_put_values(interp, array_varname, result, tupno) != TCL_OK) - { - PQclear(result); - return TCL_ERROR; - } - - loop_rc = Tcl_Eval(interp, argv[i]); - - /* The returncode of the loop body controls the loop execution */ - if (loop_rc == TCL_OK || loop_rc == TCL_CONTINUE) - /* OK or CONTINUE means start next loop invocation */ - continue; - if (loop_rc == TCL_RETURN) - { - /* RETURN means hand up the given interpreter result */ - PQclear(result); - return TCL_RETURN; - } - if (loop_rc == TCL_BREAK) - /* BREAK means leave the loop */ - break; - - PQclear(result); - return TCL_ERROR; - } - - /* - * At the end of the loop we put the number of rows we got into the - * interpreter result and clear the result set. - */ - sprintf(buf, "%d", ntup); - Tcl_SetResult(interp, buf, TCL_VOLATILE); - PQclear(result); - return TCL_OK; -} - - -/********************************** - * execute_put_values - - Put the values of one tuple into Tcl variables named like the - column names, or into an array indexed by the column names. - **********************************/ -static int -execute_put_values(Tcl_Interp *interp, CONST84 char *array_varname, - PGresult *result, int tupno) -{ - int i; - int n; - char *fname; - char *value; - - /* - * For each column get the column name and value and put it into a Tcl - * variable (either scalar or array item) - */ - n = PQnfields(result); - for (i = 0; i < n; i++) - { - fname = PQfname(result, i); - value = PQgetvalue(result, tupno, i); - - if (array_varname != NULL) - { - if (Tcl_SetVar2(interp, array_varname, fname, value, - TCL_LEAVE_ERR_MSG) == NULL) - return TCL_ERROR; - } - else - { - if (Tcl_SetVar(interp, fname, value, TCL_LEAVE_ERR_MSG) == NULL) - return TCL_ERROR; - } - } - - return TCL_OK; -} - - -/********************************** - * pg_lo_open - open a large object - - syntax: - pg_lo_open conn objOid mode - - where mode can be either 'r', 'w', or 'rw' -**********************/ - -int -Pg_lo_open(ClientData cData, Tcl_Interp *interp, int argc, CONST84 char *argv[]) -{ - PGconn *conn; - int lobjId; - int mode; - int fd; - - if (argc != 4) - { - Tcl_AppendResult(interp, "Wrong # of arguments\n", - "pg_lo_open connection lobjOid mode", 0); - return TCL_ERROR; - } - - conn = PgGetConnectionId(interp, argv[1], NULL); - if (conn == NULL) - return TCL_ERROR; - - lobjId = atoi(argv[2]); - if (strlen(argv[3]) < 1 || - strlen(argv[3]) > 2) - { - Tcl_AppendResult(interp, "mode argument must be 'r', 'w', or 'rw'", 0); - return TCL_ERROR; - } - switch (argv[3][0]) - { - case 'r': - case 'R': - mode = INV_READ; - break; - case 'w': - case 'W': - mode = INV_WRITE; - break; - default: - Tcl_AppendResult(interp, "mode argument must be 'r', 'w', or 'rw'", 0); - return TCL_ERROR; - } - switch (argv[3][1]) - { - case '\0': - break; - case 'r': - case 'R': - mode |= INV_READ; - break; - case 'w': - case 'W': - mode |= INV_WRITE; - break; - default: - Tcl_AppendResult(interp, "mode argument must be 'r', 'w', or 'rw'", 0); - return TCL_ERROR; - } - - fd = lo_open(conn, lobjId, mode); - sprintf(interp->result, "%d", fd); - return TCL_OK; -} - -/********************************** - * pg_lo_close - close a large object - - syntax: - pg_lo_close conn fd - -**********************/ -int -Pg_lo_close(ClientData cData, Tcl_Interp *interp, int argc, CONST84 char *argv[]) -{ - PGconn *conn; - int fd; - - if (argc != 3) - { - Tcl_AppendResult(interp, "Wrong # of arguments\n", - "pg_lo_close connection fd", 0); - return TCL_ERROR; - } - - conn = PgGetConnectionId(interp, argv[1], NULL); - if (conn == NULL) - return TCL_ERROR; - - fd = atoi(argv[2]); - sprintf(interp->result, "%d", lo_close(conn, fd)); - return TCL_OK; -} - -/********************************** - * pg_lo_read - reads at most len bytes from a large object into a variable named - bufVar - - syntax: - pg_lo_read conn fd bufVar len - - bufVar is the name of a variable in which to store the contents of the read - -**********************/ -#ifdef PGTCL_USE_TCLOBJ -int -Pg_lo_read(ClientData cData, Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[]) -{ - PGconn *conn; - int fd; - int nbytes = 0; - char *buf; - Tcl_Obj *bufVar; - Tcl_Obj *bufObj; - int len; - int rc = TCL_OK; - - if (objc != 5) - { - Tcl_AppendResult(interp, "Wrong # of arguments\n", - " pg_lo_read conn fd bufVar len", 0); - return TCL_ERROR; - } - - conn = PgGetConnectionId(interp, Tcl_GetStringFromObj(objv[1], NULL), - NULL); - if (conn == NULL) - return TCL_ERROR; - - if (Tcl_GetIntFromObj(interp, objv[2], &fd) != TCL_OK) - return TCL_ERROR; - - bufVar = objv[3]; - - if (Tcl_GetIntFromObj(interp, objv[4], &len) != TCL_OK) - return TCL_ERROR; - - if (len <= 0) - { - Tcl_SetObjResult(interp, Tcl_NewIntObj(nbytes)); - return TCL_OK; - } - buf = ckalloc(len + 1); - - nbytes = lo_read(conn, fd, buf, len); - - if (nbytes >= 0) - { -#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION >= 1 || TCL_MAJOR_VERSION > 8 - bufObj = Tcl_NewByteArrayObj(buf, nbytes); -#else - bufObj = Tcl_NewStringObj(buf, nbytes); -#endif - - if (Tcl_ObjSetVar2(interp, bufVar, NULL, bufObj, - TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1) == NULL) - rc = TCL_ERROR; - } - - if (rc == TCL_OK) - Tcl_SetObjResult(interp, Tcl_NewIntObj(nbytes)); - - ckfree(buf); - return rc; -} - -#else -int -Pg_lo_read(ClientData cData, Tcl_Interp *interp, int argc, CONST84 char *argv[]) -{ - PGconn *conn; - int fd; - int nbytes = 0; - char *buf; - char *bufVar; - int len; - - if (argc != 5) - { - Tcl_AppendResult(interp, "Wrong # of arguments\n", - " pg_lo_read conn fd bufVar len", 0); - return TCL_ERROR; - } - - conn = PgGetConnectionId(interp, argv[1], NULL); - if (conn == NULL) - return TCL_ERROR; - - fd = atoi(argv[2]); - - bufVar = argv[3]; - - len = atoi(argv[4]); - - if (len <= 0) - { - sprintf(interp->result, "%d", nbytes); - return TCL_OK; - } - buf = ckalloc(len + 1); - - nbytes = lo_read(conn, fd, buf, len); - - if (nbytes >= 0) - Tcl_SetVar(interp, bufVar, buf, TCL_LEAVE_ERR_MSG); - - sprintf(interp->result, "%d", nbytes); - ckfree(buf); - return TCL_OK; - -} -#endif - -/*********************************** -Pg_lo_write - write at most len bytes to a large object - - syntax: - pg_lo_write conn fd buf len - -***********************************/ -#ifdef PGTCL_USE_TCLOBJ -int -Pg_lo_write(ClientData cData, Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[]) -{ - PGconn *conn; - char *buf; - int fd; - int nbytes = 0; - int len; - - if (objc != 5) - { - Tcl_AppendResult(interp, "Wrong # of arguments\n", - "pg_lo_write conn fd buf len", 0); - return TCL_ERROR; - } - - conn = PgGetConnectionId(interp, Tcl_GetStringFromObj(objv[1], NULL), - NULL); - if (conn == NULL) - return TCL_ERROR; - - if (Tcl_GetIntFromObj(interp, objv[2], &fd) != TCL_OK) - return TCL_ERROR; - -#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION >= 1 || TCL_MAJOR_VERSION > 8 - buf = Tcl_GetByteArrayFromObj(objv[3], &nbytes); -#else - buf = Tcl_GetStringFromObj(objv[3], &nbytes); -#endif - - if (Tcl_GetIntFromObj(interp, objv[4], &len) != TCL_OK) - return TCL_ERROR; - - if (len > nbytes) - len = nbytes; - - if (len <= 0) - { - Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); - return TCL_OK; - } - - nbytes = lo_write(conn, fd, buf, len); - Tcl_SetObjResult(interp, Tcl_NewIntObj(nbytes)); - return TCL_OK; -} - -#else -int -Pg_lo_write(ClientData cData, Tcl_Interp *interp, int argc, CONST84 char *argv[]) -{ - PGconn *conn; - char *buf; - int fd; - int nbytes = 0; - int len; - - if (argc != 5) - { - Tcl_AppendResult(interp, "Wrong # of arguments\n", - "pg_lo_write conn fd buf len", 0); - return TCL_ERROR; - } - - conn = PgGetConnectionId(interp, argv[1], NULL); - if (conn == NULL) - return TCL_ERROR; - - fd = atoi(argv[2]); - - buf = argv[3]; - - len = atoi(argv[4]); - - if (len <= 0) - { - sprintf(interp->result, "%d", nbytes); - return TCL_OK; - } - - nbytes = lo_write(conn, fd, buf, len); - sprintf(interp->result, "%d", nbytes); - return TCL_OK; -} -#endif - -/*********************************** -Pg_lo_lseek - seek to a certain position in a large object - -syntax - pg_lo_lseek conn fd offset whence - -whence can be either -"SEEK_CUR", "SEEK_END", or "SEEK_SET" -***********************************/ -int -Pg_lo_lseek(ClientData cData, Tcl_Interp *interp, int argc, CONST84 char *argv[]) -{ - PGconn *conn; - int fd; - const char *whenceStr; - int offset, - whence; - - if (argc != 5) - { - Tcl_AppendResult(interp, "Wrong # of arguments\n", - "pg_lo_lseek conn fd offset whence", 0); - return TCL_ERROR; - } - - conn = PgGetConnectionId(interp, argv[1], NULL); - if (conn == NULL) - return TCL_ERROR; - - fd = atoi(argv[2]); - - offset = atoi(argv[3]); - - whenceStr = argv[4]; - if (strcmp(whenceStr, "SEEK_SET") == 0) - whence = SEEK_SET; - else if (strcmp(whenceStr, "SEEK_CUR") == 0) - whence = SEEK_CUR; - else if (strcmp(whenceStr, "SEEK_END") == 0) - whence = SEEK_END; - else - { - Tcl_AppendResult(interp, "the whence argument to Pg_lo_lseek must be SEEK_SET, SEEK_CUR or SEEK_END", 0); - return TCL_ERROR; - } - - sprintf(interp->result, "%d", lo_lseek(conn, fd, offset, whence)); - return TCL_OK; -} - - -/*********************************** -Pg_lo_creat - create a new large object with mode - - syntax: - pg_lo_creat conn mode - -mode can be any OR'ing together of INV_READ, INV_WRITE, -for now, we don't support any additional storage managers. - -***********************************/ -int -Pg_lo_creat(ClientData cData, Tcl_Interp *interp, int argc, CONST84 char *argv[]) -{ - PGconn *conn; - char *modeStr; - char *modeWord; - int mode; - - if (argc != 3) - { - Tcl_AppendResult(interp, "Wrong # of arguments\n", - "pg_lo_creat conn mode", 0); - return TCL_ERROR; - } - - conn = PgGetConnectionId(interp, argv[1], NULL); - if (conn == NULL) - return TCL_ERROR; - - modeStr = strdup(argv[2]); - - modeWord = strtok(modeStr, "|"); - if (strcmp(modeWord, "INV_READ") == 0) - mode = INV_READ; - else if (strcmp(modeWord, "INV_WRITE") == 0) - mode = INV_WRITE; - else - { - Tcl_AppendResult(interp, - "invalid mode argument to Pg_lo_creat\nmode argument must be some OR'd combination of INV_READ, and INV_WRITE", - 0); - free(modeStr); - return TCL_ERROR; - } - - while ((modeWord = strtok(NULL, "|")) != NULL) - { - if (strcmp(modeWord, "INV_READ") == 0) - mode |= INV_READ; - else if (strcmp(modeWord, "INV_WRITE") == 0) - mode |= INV_WRITE; - else - { - Tcl_AppendResult(interp, - "invalid mode argument to Pg_lo_creat\nmode argument must be some OR'd combination of INV_READ, INV_WRITE", - 0); - free(modeStr); - return TCL_ERROR; - } - } - sprintf(interp->result, "%d", lo_creat(conn, mode)); - free(modeStr); - return TCL_OK; -} - -/*********************************** -Pg_lo_tell - returns the current seek location of the large object - - syntax: - pg_lo_tell conn fd - -***********************************/ -int -Pg_lo_tell(ClientData cData, Tcl_Interp *interp, int argc, CONST84 char *argv[]) -{ - PGconn *conn; - int fd; - - if (argc != 3) - { - Tcl_AppendResult(interp, "Wrong # of arguments\n", - "pg_lo_tell conn fd", 0); - return TCL_ERROR; - } - - conn = PgGetConnectionId(interp, argv[1], NULL); - if (conn == NULL) - return TCL_ERROR; - - fd = atoi(argv[2]); - - sprintf(interp->result, "%d", lo_tell(conn, fd)); - return TCL_OK; - -} - -/*********************************** -Pg_lo_unlink - unlink a file based on lobject id - - syntax: - pg_lo_unlink conn lobjId - - -***********************************/ -int -Pg_lo_unlink(ClientData cData, Tcl_Interp *interp, int argc, CONST84 char *argv[]) -{ - PGconn *conn; - int lobjId; - int retval; - - if (argc != 3) - { - Tcl_AppendResult(interp, "Wrong # of arguments\n", - "pg_lo_tell conn fd", 0); - return TCL_ERROR; - } - - conn = PgGetConnectionId(interp, argv[1], NULL); - if (conn == NULL) - return TCL_ERROR; - - lobjId = atoi(argv[2]); - - retval = lo_unlink(conn, lobjId); - if (retval == -1) - { - sprintf(interp->result, "Pg_lo_unlink of '%d' failed", lobjId); - return TCL_ERROR; - } - - sprintf(interp->result, "%d", retval); - return TCL_OK; -} - -/*********************************** -Pg_lo_import - import a Unix file into an (inversion) large objct - returns the oid of that object upon success - returns InvalidOid upon failure - - syntax: - pg_lo_import conn filename - -***********************************/ - -int -Pg_lo_import(ClientData cData, Tcl_Interp *interp, int argc, CONST84 char *argv[]) -{ - PGconn *conn; - const char *filename; - Oid lobjId; - - if (argc != 3) - { - Tcl_AppendResult(interp, "Wrong # of arguments\n", - "pg_lo_import conn filename", 0); - return TCL_ERROR; - } - - conn = PgGetConnectionId(interp, argv[1], NULL); - if (conn == NULL) - return TCL_ERROR; - - filename = argv[2]; - - lobjId = lo_import(conn, filename); - if (lobjId == InvalidOid) - { - /* - * What is the maximum size of this? FIXME if this is not a good - * quess - */ - snprintf(interp->result, 128, "Pg_lo_import of '%s' failed", filename); - return TCL_ERROR; - } - sprintf(interp->result, "%u", lobjId); - return TCL_OK; -} - -/*********************************** -Pg_lo_export - export an Inversion large object to a Unix file - - syntax: - pg_lo_export conn lobjId filename - -***********************************/ - -int -Pg_lo_export(ClientData cData, Tcl_Interp *interp, int argc, CONST84 char *argv[]) -{ - PGconn *conn; - const char *filename; - Oid lobjId; - int retval; - - if (argc != 4) - { - Tcl_AppendResult(interp, "Wrong # of arguments\n", - "pg_lo_export conn lobjId filename", 0); - return TCL_ERROR; - } - - conn = PgGetConnectionId(interp, argv[1], NULL); - if (conn == NULL) - return TCL_ERROR; - - lobjId = atoi(argv[2]); - filename = argv[3]; - - retval = lo_export(conn, lobjId, filename); - if (retval == -1) - { - sprintf(interp->result, "Pg_lo_export %u %s failed", lobjId, filename); - return TCL_ERROR; - } - return TCL_OK; -} - -/********************************** - * pg_select - send a select query string to the backend connection - - syntax: - pg_select connection query var proc - - The query must be a select statement - The var is used in the proc as an array - The proc is run once for each row found - - Originally I was also going to update changes but that has turned out - to be not so simple. Instead, the caller should get the OID of any - table they want to update and update it themself in the loop. I may - try to write a simplified table lookup and update function to make - that task a little easier. - - The return is either TCL_OK, TCL_ERROR or TCL_RETURN and interp->result - may contain more information. - **********************************/ - -int -Pg_select(ClientData cData, Tcl_Interp *interp, int argc, CONST84 char *argv[]) -{ - Pg_ConnectionId *connid; - PGconn *conn; - PGresult *result; - int r, - retval; - int tupno, - column, - ncols; - Tcl_DString headers; - char buffer[2048]; - struct info_s - { - char *cname; - int change; - } *info; - - if (argc != 5) - { - Tcl_AppendResult(interp, "Wrong # of arguments\n", - "pg_select connection queryString var proc", 0); - return TCL_ERROR; - } - - conn = PgGetConnectionId(interp, argv[1], &connid); - if (conn == NULL) - return TCL_ERROR; - - if ((result = PQexec(conn, argv[2])) == 0) - { - /* error occurred sending the query */ - Tcl_SetResult(interp, PQerrorMessage(conn), TCL_VOLATILE); - return TCL_ERROR; - } - - /* Transfer any notify events from libpq to Tcl event queue. */ - PgNotifyTransferEvents(connid); - - if (PQresultStatus(result) != PGRES_TUPLES_OK) - { - /* query failed, or it wasn't SELECT */ - Tcl_SetResult(interp, (char *) PQresultErrorMessage(result), - TCL_VOLATILE); - PQclear(result); - return TCL_ERROR; - } - - if ((info = (struct info_s *) ckalloc(sizeof(*info) * (ncols = PQnfields(result)))) == NULL) - { - Tcl_AppendResult(interp, "Not enough memory", 0); - PQclear(result); - return TCL_ERROR; - } - - Tcl_DStringInit(&headers); - - for (column = 0; column < ncols; column++) - { - info[column].cname = PQfname(result, column); - info[column].change = 0; - Tcl_DStringAppendElement(&headers, info[column].cname); - } - - Tcl_SetVar2(interp, argv[3], ".headers", Tcl_DStringValue(&headers), 0); - Tcl_DStringFree(&headers); - sprintf(buffer, "%d", ncols); - Tcl_SetVar2(interp, argv[3], ".numcols", buffer, 0); - - retval = TCL_OK; - - for (tupno = 0; tupno < PQntuples(result); tupno++) - { - sprintf(buffer, "%d", tupno); - Tcl_SetVar2(interp, argv[3], ".tupno", buffer, 0); - - for (column = 0; column < ncols; column++) - Tcl_SetVar2(interp, argv[3], info[column].cname, -#ifdef TCL_ARRAYS - tcl_value(PQgetvalue(result, tupno, column)), -#else - PQgetvalue(result, tupno, column), -#endif - 0); - - Tcl_SetVar2(interp, argv[3], ".command", "update", 0); - - if ((r = Tcl_Eval(interp, argv[4])) != TCL_OK && r != TCL_CONTINUE) - { - if (r == TCL_BREAK) - break; /* exit loop, but return TCL_OK */ - - if (r == TCL_ERROR) - { - char msg[60]; - - sprintf(msg, "\n (\"pg_select\" body line %d)", - interp->errorLine); - Tcl_AddErrorInfo(interp, msg); - } - - retval = r; - break; - } - } - - ckfree((void *) info); - Tcl_UnsetVar(interp, argv[3], 0); - PQclear(result); - return retval; -} - -/* - * Test whether any callbacks are registered on this connection for - * the given relation name. NB: supplied name must be case-folded already. - */ - -static int -Pg_have_listener(Pg_ConnectionId * connid, const char *relname) -{ - Pg_TclNotifies *notifies; - Tcl_HashEntry *entry; - - for (notifies = connid->notify_list; - notifies != NULL; - notifies = notifies->next) - { - Tcl_Interp *interp = notifies->interp; - - if (interp == NULL) - continue; /* ignore deleted interpreter */ - - entry = Tcl_FindHashEntry(¬ifies->notify_hash, (char *) relname); - if (entry == NULL) - continue; /* no pg_listen in this interpreter */ - - return TRUE; /* OK, there is a listener */ - } - - return FALSE; /* Found no listener */ -} - -/*********************************** -Pg_listen - create or remove a callback request for notifies on a given name - - syntax: - pg_listen conn notifyname ?callbackcommand? - - With a fourth arg, creates or changes the callback command for - notifies on the given name; without, cancels the callback request. - - Callbacks can occur whenever Tcl is executing its event loop. - This is the normal idle loop in Tk; in plain tclsh applications, - vwait or update can be used to enter the Tcl event loop. -***********************************/ -int -Pg_listen(ClientData cData, Tcl_Interp *interp, int argc, CONST84 char *argv[]) -{ - const char *origrelname; - char *caserelname; - char *callback = NULL; - Pg_TclNotifies *notifies; - Tcl_HashEntry *entry; - Pg_ConnectionId *connid; - PGconn *conn; - PGresult *result; - int new; - - if (argc < 3 || argc > 4) - { - Tcl_AppendResult(interp, "wrong # args, should be \"", - argv[0], " connection relname ?callback?\"", 0); - return TCL_ERROR; - } - - /* - * Get the command arguments. Note that the relation name will be - * copied by Tcl_CreateHashEntry while the callback string must be - * allocated by us. - */ - conn = PgGetConnectionId(interp, argv[1], &connid); - if (conn == NULL) - return TCL_ERROR; - - /* - * LISTEN/NOTIFY do not preserve case unless the relation name is - * quoted. We have to do the same thing to ensure that we will find - * the desired pg_listen item. - */ - origrelname = argv[2]; - caserelname = (char *) ckalloc((unsigned) (strlen(origrelname) + 1)); - if (*origrelname == '"') - { - /* Copy a quoted string without downcasing */ - strcpy(caserelname, origrelname + 1); - caserelname[strlen(caserelname) - 1] = '\0'; - } - else - { - /* Downcase it */ - const char *rels = origrelname; - char *reld = caserelname; - - while (*rels) - *reld++ = tolower((unsigned char) *rels++); - *reld = '\0'; - } - - if ((argc > 3) && *argv[3]) - { - callback = (char *) ckalloc((unsigned) (strlen(argv[3]) + 1)); - strcpy(callback, argv[3]); - } - - /* Find or make a Pg_TclNotifies struct for this interp and connection */ - - for (notifies = connid->notify_list; notifies; notifies = notifies->next) - { - if (notifies->interp == interp) - break; - } - if (notifies == NULL) - { - notifies = (Pg_TclNotifies *) ckalloc(sizeof(Pg_TclNotifies)); - notifies->interp = interp; - Tcl_InitHashTable(¬ifies->notify_hash, TCL_STRING_KEYS); - notifies->conn_loss_cmd = NULL; - notifies->next = connid->notify_list; - connid->notify_list = notifies; - Tcl_CallWhenDeleted(interp, PgNotifyInterpDelete, - (ClientData) notifies); - } - - if (callback) - { - /* - * Create or update a callback for a relation - */ - int alreadyHadListener = Pg_have_listener(connid, caserelname); - - entry = Tcl_CreateHashEntry(¬ifies->notify_hash, caserelname, &new); - /* If update, free the old callback string */ - if (!new) - ckfree((char *) Tcl_GetHashValue(entry)); - /* Store the new callback string */ - Tcl_SetHashValue(entry, callback); - - /* Start the notify event source if it isn't already running */ - PgStartNotifyEventSource(connid); - - /* - * Send a LISTEN command if this is the first listener. - */ - if (!alreadyHadListener) - { - char *cmd = (char *) - ckalloc((unsigned) (strlen(origrelname) + 8)); - - sprintf(cmd, "LISTEN %s", origrelname); - result = PQexec(conn, cmd); - ckfree(cmd); - /* Transfer any notify events from libpq to Tcl event queue. */ - PgNotifyTransferEvents(connid); - if (PQresultStatus(result) != PGRES_COMMAND_OK) - { - /* Error occurred during the execution of command */ - PQclear(result); - Tcl_DeleteHashEntry(entry); - ckfree(callback); - ckfree(caserelname); - Tcl_SetResult(interp, PQerrorMessage(conn), TCL_VOLATILE); - return TCL_ERROR; - } - PQclear(result); - } - } - else - { - /* - * Remove a callback for a relation - */ - entry = Tcl_FindHashEntry(¬ifies->notify_hash, caserelname); - if (entry == NULL) - { - Tcl_AppendResult(interp, "not listening on ", origrelname, 0); - ckfree(caserelname); - return TCL_ERROR; - } - ckfree((char *) Tcl_GetHashValue(entry)); - Tcl_DeleteHashEntry(entry); - - /* - * Send an UNLISTEN command if that was the last listener. Note: - * we don't attempt to turn off the notify mechanism if no LISTENs - * remain active; not worth the trouble. - */ - if (!Pg_have_listener(connid, caserelname)) - { - char *cmd = (char *) - ckalloc((unsigned) (strlen(origrelname) + 10)); - - sprintf(cmd, "UNLISTEN %s", origrelname); - result = PQexec(conn, cmd); - ckfree(cmd); - /* Transfer any notify events from libpq to Tcl event queue. */ - PgNotifyTransferEvents(connid); - if (PQresultStatus(result) != PGRES_COMMAND_OK) - { - /* Error occurred during the execution of command */ - PQclear(result); - ckfree(caserelname); - Tcl_SetResult(interp, PQerrorMessage(conn), TCL_VOLATILE); - return TCL_ERROR; - } - PQclear(result); - } - } - - ckfree(caserelname); - return TCL_OK; -} - -/*********************************** -Pg_on_connection_loss - create or remove a callback request for unexpected connection loss - - syntax: - pg_on_connection_loss conn ?callbackcommand? - - With a third arg, creates or changes the callback command for - connection loss; without, cancels the callback request. - - Callbacks can occur whenever Tcl is executing its event loop. - This is the normal idle loop in Tk; in plain tclsh applications, - vwait or update can be used to enter the Tcl event loop. -***********************************/ -int -Pg_on_connection_loss(ClientData cData, Tcl_Interp *interp, int argc, CONST84 char *argv[]) -{ - char *callback = NULL; - Pg_TclNotifies *notifies; - Pg_ConnectionId *connid; - PGconn *conn; - - if (argc < 2 || argc > 3) - { - Tcl_AppendResult(interp, "wrong # args, should be \"", - argv[0], " connection ?callback?\"", 0); - return TCL_ERROR; - } - - /* - * Get the command arguments. - */ - conn = PgGetConnectionId(interp, argv[1], &connid); - if (conn == NULL) - return TCL_ERROR; - - if ((argc > 2) && *argv[2]) - { - callback = (char *) ckalloc((unsigned) (strlen(argv[2]) + 1)); - strcpy(callback, argv[2]); - } - - /* Find or make a Pg_TclNotifies struct for this interp and connection */ - - for (notifies = connid->notify_list; notifies; notifies = notifies->next) - { - if (notifies->interp == interp) - break; - } - if (notifies == NULL) - { - notifies = (Pg_TclNotifies *) ckalloc(sizeof(Pg_TclNotifies)); - notifies->interp = interp; - Tcl_InitHashTable(¬ifies->notify_hash, TCL_STRING_KEYS); - notifies->conn_loss_cmd = NULL; - notifies->next = connid->notify_list; - connid->notify_list = notifies; - Tcl_CallWhenDeleted(interp, PgNotifyInterpDelete, - (ClientData) notifies); - } - - /* Store new callback setting */ - - if (notifies->conn_loss_cmd) - ckfree((void *) notifies->conn_loss_cmd); - notifies->conn_loss_cmd = callback; - - if (callback) - { - /* - * Start the notify event source if it isn't already running. The - * notify source will cause Tcl to watch read-ready on the - * connection socket, so that we find out quickly if the - * connection drops. - */ - PgStartNotifyEventSource(connid); - } - - return TCL_OK; -} diff --git a/src/interfaces/libpgtcl/pgtclCmds.h b/src/interfaces/libpgtcl/pgtclCmds.h deleted file mode 100644 index 4026ee449c..0000000000 --- a/src/interfaces/libpgtcl/pgtclCmds.h +++ /dev/null @@ -1,143 +0,0 @@ -/*------------------------------------------------------------------------- - * - * pgtclCmds.h - * declarations for the C functions which implement pg_* tcl commands - * - * Portions Copyright (c) 1996-2003, PostgreSQL Global Development Group - * Portions Copyright (c) 1994, Regents of the University of California - * - * $PostgreSQL: pgsql/src/interfaces/libpgtcl/pgtclCmds.h,v 1.32 2003/11/29 22:41:25 pgsql Exp $ - * - *------------------------------------------------------------------------- - */ - -#ifndef PGTCLCMDS_H -#define PGTCLCMDS_H - -#include - -#include "libpq-fe.h" - -/* Hack to deal with Tcl 8.4 const-ification without losing compatibility */ -#ifndef CONST84 -#define CONST84 -#endif - -#define RES_HARD_MAX 128 -#define RES_START 16 - -/* - * From Tcl version 8.0 on we can make large object access binary. - */ -#ifdef TCL_MAJOR_VERSION -#if (TCL_MAJOR_VERSION >= 8) -#define PGTCL_USE_TCLOBJ -#endif -#endif - -/* - * Each Pg_ConnectionId has a list of Pg_TclNotifies structs, one for each - * Tcl interpreter that has executed any pg_listens on the connection. - * We need this arrangement to be able to clean up if an interpreter is - * deleted while the connection remains open. A free side benefit is that - * multiple interpreters can be registered to listen for the same notify - * name. (All their callbacks will be called, but in an unspecified order.) - * - * We use the same approach for pg_on_connection_loss callbacks, but they - * are not kept in a hashtable since there's no name associated. - */ - -typedef struct Pg_TclNotifies_s -{ - struct Pg_TclNotifies_s *next; /* list link */ - Tcl_Interp *interp; /* This Tcl interpreter */ - - /* - * NB: if interp == NULL, the interpreter is gone but we haven't yet - * got round to deleting the Pg_TclNotifies structure. - */ - Tcl_HashTable notify_hash; /* Active pg_listen requests */ - - char *conn_loss_cmd; /* pg_on_connection_loss cmd, or NULL */ -} Pg_TclNotifies; - -typedef struct Pg_ConnectionId_s -{ - char id[32]; - PGconn *conn; - int res_max; /* Max number of results allocated */ - int res_hardmax; /* Absolute max to allow */ - int res_count; /* Current count of active results */ - int res_last; /* Optimize where to start looking */ - int res_copy; /* Query result with active copy */ - int res_copyStatus; /* Copying status */ - PGresult **results; /* The results */ - - Pg_TclNotifies *notify_list; /* head of list of notify info */ - int notifier_running; /* notify event source is live */ -#if TCL_MAJOR_VERSION >= 8 - Tcl_Channel notifier_channel; /* Tcl_Channel on which notifier - * is listening */ -#else - int notifier_socket; /* PQsocket on which notifier is listening */ -#endif -} Pg_ConnectionId; - -/* Values of res_copyStatus */ -#define RES_COPY_NONE 0 -#define RES_COPY_INPROGRESS 1 -#define RES_COPY_FIN 2 - - -/* **************************/ -/* registered Tcl functions */ -/* **************************/ -extern int Pg_conndefaults(ClientData cData, Tcl_Interp *interp, - int argc, CONST84 char *argv[]); -extern int Pg_connect(ClientData cData, Tcl_Interp *interp, - int argc, CONST84 char *argv[]); -extern int Pg_disconnect(ClientData cData, Tcl_Interp *interp, - int argc, CONST84 char *argv[]); -extern int Pg_exec(ClientData cData, Tcl_Interp *interp, - int argc, CONST84 char *argv[]); -extern int Pg_execute(ClientData cData, Tcl_Interp *interp, - int argc, CONST84 char *argv[]); -extern int Pg_select(ClientData cData, Tcl_Interp *interp, - int argc, CONST84 char *argv[]); -extern int Pg_result(ClientData cData, Tcl_Interp *interp, - int argc, CONST84 char *argv[]); -extern int Pg_lo_open(ClientData cData, Tcl_Interp *interp, - int argc, CONST84 char *argv[]); -extern int Pg_lo_close(ClientData cData, Tcl_Interp *interp, - int argc, CONST84 char *argv[]); - -#ifdef PGTCL_USE_TCLOBJ -extern int Pg_lo_read(ClientData cData, Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[]); -extern int Pg_lo_write(ClientData cData, Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[]); - -#else -extern int Pg_lo_read(ClientData cData, Tcl_Interp *interp, - int argc, CONST84 char *argv[]); -extern int Pg_lo_write(ClientData cData, Tcl_Interp *interp, - int argc, CONST84 char *argv[]); -#endif -extern int Pg_lo_lseek(ClientData cData, Tcl_Interp *interp, - int argc, CONST84 char *argv[]); -extern int Pg_lo_creat(ClientData cData, Tcl_Interp *interp, - int argc, CONST84 char *argv[]); -extern int Pg_lo_tell(ClientData cData, Tcl_Interp *interp, - int argc, CONST84 char *argv[]); -extern int Pg_lo_unlink(ClientData cData, Tcl_Interp *interp, - int argc, CONST84 char *argv[]); -extern int Pg_lo_import(ClientData cData, Tcl_Interp *interp, - int argc, CONST84 char *argv[]); -extern int Pg_lo_export(ClientData cData, Tcl_Interp *interp, - int argc, CONST84 char *argv[]); -extern int Pg_listen(ClientData cData, Tcl_Interp *interp, - int argc, CONST84 char *argv[]); -extern int Pg_on_connection_loss(ClientData cData, Tcl_Interp *interp, - int argc, CONST84 char *argv[]); - -#endif /* PGTCLCMDS_H */ diff --git a/src/interfaces/libpgtcl/pgtclId.c b/src/interfaces/libpgtcl/pgtclId.c deleted file mode 100644 index 1cdd85b975..0000000000 --- a/src/interfaces/libpgtcl/pgtclId.c +++ /dev/null @@ -1,862 +0,0 @@ -/*------------------------------------------------------------------------- - * - * pgtclId.c - * - * Contains Tcl "channel" interface routines, plus useful routines - * to convert between strings and pointers. These are needed because - * everything in Tcl is a string, but in C, pointers to data structures - * are needed. - * - * ASSUMPTION: sizeof(long) >= sizeof(void*) - * - * Portions Copyright (c) 1996-2003, PostgreSQL Global Development Group - * Portions Copyright (c) 1994, Regents of the University of California - * - * IDENTIFICATION - * $PostgreSQL: pgsql/src/interfaces/libpgtcl/pgtclId.c,v 1.45 2004/01/07 18:56:29 neilc Exp $ - * - *------------------------------------------------------------------------- - */ -#include "postgres_fe.h" - -#include - -#include "pgtclCmds.h" -#include "pgtclId.h" - - -static int -PgEndCopy(Pg_ConnectionId * connid, int *errorCodePtr) -{ - connid->res_copyStatus = RES_COPY_NONE; - if (PQendcopy(connid->conn)) - { - PQclear(connid->results[connid->res_copy]); - connid->results[connid->res_copy] = - PQmakeEmptyPGresult(connid->conn, PGRES_BAD_RESPONSE); - connid->res_copy = -1; - *errorCodePtr = EIO; - return -1; - } - else - { - PQclear(connid->results[connid->res_copy]); - connid->results[connid->res_copy] = - PQmakeEmptyPGresult(connid->conn, PGRES_COMMAND_OK); - connid->res_copy = -1; - return 0; - } -} - -/* - * Called when reading data (via gets) for a copy to stdout. - */ -int -PgInputProc(DRIVER_INPUT_PROTO) -{ - Pg_ConnectionId *connid; - PGconn *conn; - int avail; - - connid = (Pg_ConnectionId *) cData; - conn = connid->conn; - - if (connid->res_copy < 0 || - PQresultStatus(connid->results[connid->res_copy]) != PGRES_COPY_OUT) - { - *errorCodePtr = EBUSY; - return -1; - } - - /* - * Read any newly arrived data into libpq's buffer, thereby clearing - * the socket's read-ready condition. - */ - if (!PQconsumeInput(conn)) - { - *errorCodePtr = EIO; - return -1; - } - - /* Move data from libpq's buffer to Tcl's. */ - - avail = PQgetlineAsync(conn, buf, bufSize); - - if (avail < 0) - { - /* Endmarker detected, change state and return 0 */ - return PgEndCopy(connid, errorCodePtr); - } - - return avail; -} - -/* - * Called when writing data (via puts) for a copy from stdin - */ -int -PgOutputProc(DRIVER_OUTPUT_PROTO) -{ - Pg_ConnectionId *connid; - PGconn *conn; - - connid = (Pg_ConnectionId *) cData; - conn = connid->conn; - - if (connid->res_copy < 0 || - PQresultStatus(connid->results[connid->res_copy]) != PGRES_COPY_IN) - { - *errorCodePtr = EBUSY; - return -1; - } - - if (PQputnbytes(conn, buf, bufSize)) - { - *errorCodePtr = EIO; - return -1; - } - - /* - * This assumes Tcl script will write the terminator line in a single - * operation; maybe not such a good assumption? - */ - if (bufSize >= 3 && strncmp(&buf[bufSize - 3], "\\.\n", 3) == 0) - { - if (PgEndCopy(connid, errorCodePtr) == -1) - return -1; - } - return bufSize; -} - -#if HAVE_TCL_GETFILEPROC - -Tcl_File -PgGetFileProc(ClientData cData, int direction) -{ - return NULL; -} -#endif - -/* - * The WatchProc and GetHandleProc are no-ops but must be present. - */ -static void -PgWatchProc(ClientData instanceData, int mask) -{ -} - -static int -PgGetHandleProc(ClientData instanceData, int direction, - ClientData *handlePtr) -{ - return TCL_ERROR; -} - -Tcl_ChannelType Pg_ConnType = { - "pgsql", /* channel type */ - NULL, /* blockmodeproc */ - PgDelConnectionId, /* closeproc */ - PgInputProc, /* inputproc */ - PgOutputProc, /* outputproc */ - NULL, /* SeekProc, Not used */ - NULL, /* SetOptionProc, Not used */ - NULL, /* GetOptionProc, Not used */ - PgWatchProc, /* WatchProc, must be defined */ - PgGetHandleProc, /* GetHandleProc, must be defined */ - NULL /* Close2Proc, Not used */ -}; - -/* - * Create and register a new channel for the connection - */ -void -PgSetConnectionId(Tcl_Interp *interp, PGconn *conn) -{ - Tcl_Channel conn_chan; - Pg_ConnectionId *connid; - int i; - - connid = (Pg_ConnectionId *) ckalloc(sizeof(Pg_ConnectionId)); - connid->conn = conn; - connid->res_count = 0; - connid->res_last = -1; - connid->res_max = RES_START; - connid->res_hardmax = RES_HARD_MAX; - connid->res_copy = -1; - connid->res_copyStatus = RES_COPY_NONE; - connid->results = (PGresult **) ckalloc(sizeof(PGresult *) * RES_START); - for (i = 0; i < RES_START; i++) - connid->results[i] = NULL; - connid->notify_list = NULL; - connid->notifier_running = 0; - - sprintf(connid->id, "pgsql%d", PQsocket(conn)); - -#if TCL_MAJOR_VERSION >= 8 - connid->notifier_channel = Tcl_MakeTcpClientChannel((ClientData) PQsocket(conn)); - Tcl_RegisterChannel(NULL, connid->notifier_channel); -#else - connid->notifier_socket = -1; -#endif - -#if TCL_MAJOR_VERSION == 7 && TCL_MINOR_VERSION == 5 - /* Original signature (only seen in Tcl 7.5) */ - conn_chan = Tcl_CreateChannel(&Pg_ConnType, connid->id, NULL, NULL, (ClientData) connid); -#else - /* Tcl 7.6 and later use this */ - conn_chan = Tcl_CreateChannel(&Pg_ConnType, connid->id, (ClientData) connid, - TCL_READABLE | TCL_WRITABLE); -#endif - - Tcl_SetChannelOption(interp, conn_chan, "-buffering", "line"); - Tcl_SetResult(interp, connid->id, TCL_VOLATILE); - Tcl_RegisterChannel(interp, conn_chan); -} - - -/* - * Get back the connection from the Id - */ -PGconn * -PgGetConnectionId(Tcl_Interp *interp, CONST84 char *id, - Pg_ConnectionId ** connid_p) -{ - Tcl_Channel conn_chan; - Pg_ConnectionId *connid; - - conn_chan = Tcl_GetChannel(interp, id, 0); - if (conn_chan == NULL || Tcl_GetChannelType(conn_chan) != &Pg_ConnType) - { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, id, " is not a valid postgresql connection", 0); - if (connid_p) - *connid_p = NULL; - return NULL; - } - - connid = (Pg_ConnectionId *) Tcl_GetChannelInstanceData(conn_chan); - if (connid_p) - *connid_p = connid; - return connid->conn; -} - - -/* - * Remove a connection Id from the hash table and - * close all portals the user forgot. - */ -int -PgDelConnectionId(DRIVER_DEL_PROTO) -{ - Tcl_HashEntry *entry; - Tcl_HashSearch hsearch; - Pg_ConnectionId *connid; - Pg_TclNotifies *notifies; - int i; - - connid = (Pg_ConnectionId *) cData; - - for (i = 0; i < connid->res_max; i++) - { - if (connid->results[i]) - PQclear(connid->results[i]); - } - ckfree((void *) connid->results); - - /* Release associated notify info */ - while ((notifies = connid->notify_list) != NULL) - { - connid->notify_list = notifies->next; - for (entry = Tcl_FirstHashEntry(¬ifies->notify_hash, &hsearch); - entry != NULL; - entry = Tcl_NextHashEntry(&hsearch)) - ckfree((char *) Tcl_GetHashValue(entry)); - Tcl_DeleteHashTable(¬ifies->notify_hash); - if (notifies->conn_loss_cmd) - ckfree((void *) notifies->conn_loss_cmd); - if (notifies->interp) - Tcl_DontCallWhenDeleted(notifies->interp, PgNotifyInterpDelete, - (ClientData) notifies); - ckfree((void *) notifies); - } - - /* - * Turn off the Tcl event source for this connection, and delete any - * pending notify and connection-loss events. - */ - PgStopNotifyEventSource(connid, true); - - /* Close the libpq connection too */ - PQfinish(connid->conn); - connid->conn = NULL; - - /* - * Kill the notifier channel, too. We must not do this until after - * we've closed the libpq connection, because Tcl will try to close - * the socket itself! - * - * XXX Unfortunately, while this works fine if we are closing due to - * explicit pg_disconnect, all Tcl versions through 8.4.1 dump core if - * we try to do it during interpreter shutdown. Not clear why. For - * now, we kill the channel during pg_disconnect, but during interp - * shutdown we just accept leakage of the (fairly small) amount of - * memory taken for the channel state representation. (Note we are not - * leaking a socket, since libpq closed that already.) We tell the - * difference between pg_disconnect and interpreter shutdown by - * testing for interp != NULL, which is an undocumented but apparently - * safe way to tell. - */ -#if TCL_MAJOR_VERSION >= 8 - if (connid->notifier_channel != NULL && interp != NULL) - Tcl_UnregisterChannel(NULL, connid->notifier_channel); -#endif - - /* - * We must use Tcl_EventuallyFree because we don't want the connid - * struct to vanish instantly if Pg_Notify_EventProc is active for it. - * (Otherwise, closing the connection from inside a pg_listen callback - * could lead to coredump.) Pg_Notify_EventProc can detect that the - * connection has been deleted from under it by checking connid->conn. - */ - Tcl_EventuallyFree((ClientData) connid, TCL_DYNAMIC); - - return 0; -} - - -/* - * Find a slot for a new result id. If the table is full, expand it by - * a factor of 2. However, do not expand past the hard max, as the client - * is probably just not clearing result handles like they should. - */ -int -PgSetResultId(Tcl_Interp *interp, CONST84 char *connid_c, PGresult *res) -{ - Tcl_Channel conn_chan; - Pg_ConnectionId *connid; - int resid, - i; - char buf[32]; - - - conn_chan = Tcl_GetChannel(interp, connid_c, 0); - if (conn_chan == NULL) - return TCL_ERROR; - connid = (Pg_ConnectionId *) Tcl_GetChannelInstanceData(conn_chan); - - /* search, starting at slot after the last one used */ - resid = connid->res_last; - for (;;) - { - /* advance, with wraparound */ - if (++resid >= connid->res_max) - resid = 0; - /* this slot empty? */ - if (!connid->results[resid]) - { - connid->res_last = resid; - break; /* success exit */ - } - /* checked all slots? */ - if (resid == connid->res_last) - break; /* failure exit */ - } - - if (connid->results[resid]) - { - /* no free slot found, so try to enlarge array */ - if (connid->res_max >= connid->res_hardmax) - { - Tcl_SetResult(interp, "hard limit on result handles reached", - TCL_STATIC); - return TCL_ERROR; - } - connid->res_last = resid = connid->res_max; - connid->res_max *= 2; - if (connid->res_max > connid->res_hardmax) - connid->res_max = connid->res_hardmax; - connid->results = (PGresult **) ckrealloc((void *) connid->results, - sizeof(PGresult *) * connid->res_max); - for (i = connid->res_last; i < connid->res_max; i++) - connid->results[i] = NULL; - } - - connid->results[resid] = res; - sprintf(buf, "%s.%d", connid_c, resid); - Tcl_SetResult(interp, buf, TCL_VOLATILE); - return resid; -} - -static int -getresid(Tcl_Interp *interp, CONST84 char *id, Pg_ConnectionId ** connid_p) -{ - Tcl_Channel conn_chan; - char *mark; - int resid; - Pg_ConnectionId *connid; - - if (!(mark = strchr(id, '.'))) - return -1; - *mark = '\0'; - conn_chan = Tcl_GetChannel(interp, id, 0); - *mark = '.'; - if (conn_chan == NULL || Tcl_GetChannelType(conn_chan) != &Pg_ConnType) - { - Tcl_SetResult(interp, "Invalid connection handle", TCL_STATIC); - return -1; - } - - if (Tcl_GetInt(interp, mark + 1, &resid) == TCL_ERROR) - { - Tcl_SetResult(interp, "Poorly formated result handle", TCL_STATIC); - return -1; - } - - connid = (Pg_ConnectionId *) Tcl_GetChannelInstanceData(conn_chan); - - if (resid < 0 || resid >= connid->res_max || connid->results[resid] == NULL) - { - Tcl_SetResult(interp, "Invalid result handle", TCL_STATIC); - return -1; - } - - *connid_p = connid; - - return resid; -} - - -/* - * Get back the result pointer from the Id - */ -PGresult * -PgGetResultId(Tcl_Interp *interp, CONST84 char *id) -{ - Pg_ConnectionId *connid; - int resid; - - if (!id) - return NULL; - resid = getresid(interp, id, &connid); - if (resid == -1) - return NULL; - return connid->results[resid]; -} - - -/* - * Remove a result Id from the hash tables - */ -void -PgDelResultId(Tcl_Interp *interp, CONST84 char *id) -{ - Pg_ConnectionId *connid; - int resid; - - resid = getresid(interp, id, &connid); - if (resid == -1) - return; - connid->results[resid] = 0; -} - - -/* - * Get the connection Id from the result Id - */ -int -PgGetConnByResultId(Tcl_Interp *interp, CONST84 char *resid_c) -{ - char *mark; - Tcl_Channel conn_chan; - - if (!(mark = strchr(resid_c, '.'))) - goto error_out; - *mark = '\0'; - conn_chan = Tcl_GetChannel(interp, resid_c, 0); - *mark = '.'; - if (conn_chan && Tcl_GetChannelType(conn_chan) == &Pg_ConnType) - { - Tcl_SetResult(interp, (char *) Tcl_GetChannelName(conn_chan), - TCL_VOLATILE); - return TCL_OK; - } - -error_out: - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, resid_c, " is not a valid connection\n", 0); - return TCL_ERROR; -} - - - - -/*------------------------------------------- - Notify event source - - These functions allow asynchronous notify messages arriving from - the SQL server to be dispatched as Tcl events. See the Tcl - Notifier(3) man page for more info. - - The main trick in this code is that we have to cope with status changes - between the queueing and the execution of a Tcl event. For example, - if the user changes or cancels the pg_listen callback command, we should - use the new setting; we do that by not resolving the notify relation - name until the last possible moment. - We also have to handle closure of the channel or deletion of the interpreter - to be used for the callback (note that with multiple interpreters, - the channel can outlive the interpreter it was created by!) - Upon closure of the channel, we immediately delete the file event handler - for it, which has the effect of disabling any file-ready events that might - be hanging about in the Tcl event queue. But for interpreter deletion, - we just set any matching interp pointers in the Pg_TclNotifies list to NULL. - The list item stays around until the connection is deleted. (This avoids - trouble with walking through a list whose members may get deleted under us.) - - Another headache is that Ousterhout keeps changing the Tcl I/O interfaces. - libpgtcl currently claims to work with Tcl 7.5, 7.6, and 8.0, and each of - 'em is different. Worse, the Tcl_File type went away in 8.0, which means - there is no longer any platform-independent way of waiting for file ready. - So we now have to use a Unix-specific interface. Grumble. - - In the current design, Pg_Notify_FileHandler is a file handler that - we establish by calling Tcl_CreateFileHandler(). It gets invoked from - the Tcl event loop whenever the underlying PGconn's socket is read-ready. - We suck up any available data (to clear the OS-level read-ready condition) - and then transfer any available PGnotify events into the Tcl event queue. - Eventually these events will be dispatched to Pg_Notify_EventProc. When - we do an ordinary PQexec, we must also transfer PGnotify events into Tcl's - event queue, since libpq might have read them when we weren't looking. - ------------------------------------------*/ - -typedef struct -{ - Tcl_Event header; /* Standard Tcl event info */ - PGnotify *notify; /* Notify event from libpq, or NULL */ - /* We use a NULL notify pointer to denote a connection-loss event */ - Pg_ConnectionId *connid; /* Connection for server */ -} NotifyEvent; - -/* Dispatch a NotifyEvent that has reached the front of the event queue */ - -static int -Pg_Notify_EventProc(Tcl_Event *evPtr, int flags) -{ - NotifyEvent *event = (NotifyEvent *) evPtr; - Pg_TclNotifies *notifies; - char *callback; - char *svcallback; - - /* We classify SQL notifies as Tcl file events. */ - if (!(flags & TCL_FILE_EVENTS)) - return 0; - - /* If connection's been closed, just forget the whole thing. */ - if (event->connid == NULL) - { - if (event->notify) - PQfreemem(event->notify); - return 1; - } - - /* - * Preserve/Release to ensure the connection struct doesn't disappear - * underneath us. - */ - Tcl_Preserve((ClientData) event->connid); - - /* - * Loop for each interpreter that has ever registered on the - * connection. Each one can get a callback. - */ - - for (notifies = event->connid->notify_list; - notifies != NULL; - notifies = notifies->next) - { - Tcl_Interp *interp = notifies->interp; - - if (interp == NULL) - continue; /* ignore deleted interpreter */ - - /* - * Find the callback to be executed for this interpreter, if any. - */ - if (event->notify) - { - /* Ordinary NOTIFY event */ - Tcl_HashEntry *entry; - - entry = Tcl_FindHashEntry(¬ifies->notify_hash, - event->notify->relname); - if (entry == NULL) - continue; /* no pg_listen in this interpreter */ - callback = (char *) Tcl_GetHashValue(entry); - } - else - { - /* Connection-loss event */ - callback = notifies->conn_loss_cmd; - } - - if (callback == NULL) - continue; /* nothing to do for this interpreter */ - - /* - * We have to copy the callback string in case the user executes a - * new pg_listen or pg_on_connection_loss during the callback. - */ - svcallback = (char *) ckalloc((unsigned) (strlen(callback) + 1)); - strcpy(svcallback, callback); - - /* - * Execute the callback. - */ - Tcl_Preserve((ClientData) interp); - if (Tcl_GlobalEval(interp, svcallback) != TCL_OK) - { - if (event->notify) - Tcl_AddErrorInfo(interp, "\n (\"pg_listen\" script)"); - else - Tcl_AddErrorInfo(interp, "\n (\"pg_on_connection_loss\" script)"); - Tcl_BackgroundError(interp); - } - Tcl_Release((ClientData) interp); - ckfree(svcallback); - - /* - * Check for the possibility that the callback closed the - * connection. - */ - if (event->connid->conn == NULL) - break; - } - - Tcl_Release((ClientData) event->connid); - - if (event->notify) - PQfreemem(event->notify); - - return 1; -} - -/* - * Transfer any notify events available from libpq into the Tcl event queue. - * Note that this must be called after each PQexec (to capture notifies - * that arrive during command execution) as well as in Pg_Notify_FileHandler - * (to capture notifies that arrive when we're idle). - */ - -void -PgNotifyTransferEvents(Pg_ConnectionId * connid) -{ - PGnotify *notify; - - while ((notify = PQnotifies(connid->conn)) != NULL) - { - NotifyEvent *event = (NotifyEvent *) ckalloc(sizeof(NotifyEvent)); - - event->header.proc = Pg_Notify_EventProc; - event->notify = notify; - event->connid = connid; - Tcl_QueueEvent((Tcl_Event *) event, TCL_QUEUE_TAIL); - } - - /* - * This is also a good place to check for unexpected closure of the - * connection (ie, backend crash), in which case we must shut down the - * notify event source to keep Tcl from trying to select() on the now- - * closed socket descriptor. But don't kill on-connection-loss - * events; in fact, register one. - */ - if (PQsocket(connid->conn) < 0) - PgConnLossTransferEvents(connid); -} - -/* - * Handle a connection-loss event - */ -void -PgConnLossTransferEvents(Pg_ConnectionId * connid) -{ - if (connid->notifier_running) - { - /* Put the on-connection-loss event in the Tcl queue */ - NotifyEvent *event = (NotifyEvent *) ckalloc(sizeof(NotifyEvent)); - - event->header.proc = Pg_Notify_EventProc; - event->notify = NULL; - event->connid = connid; - Tcl_QueueEvent((Tcl_Event *) event, TCL_QUEUE_TAIL); - } - - /* - * Shut down the notify event source to keep Tcl from trying to - * select() on the now-closed socket descriptor. And zap any - * unprocessed notify events ... but not, of course, the - * connection-loss event. - */ - PgStopNotifyEventSource(connid, false); -} - -/* - * Cleanup code for coping when an interpreter or a channel is deleted. - * - * PgNotifyInterpDelete is registered as an interpreter deletion callback - * for each extant Pg_TclNotifies structure. - * NotifyEventDeleteProc is used by PgStopNotifyEventSource to cancel - * pending Tcl NotifyEvents that reference a dying connection. - */ - -void -PgNotifyInterpDelete(ClientData clientData, Tcl_Interp *interp) -{ - /* Mark the interpreter dead, but don't do anything else yet */ - Pg_TclNotifies *notifies = (Pg_TclNotifies *) clientData; - - notifies->interp = NULL; -} - -/* - * Comparison routines for detecting events to be removed by Tcl_DeleteEvents. - * NB: In (at least) Tcl versions 7.6 through 8.0.3, there is a serious - * bug in Tcl_DeleteEvents: if there are multiple events on the queue and - * you tell it to delete the last one, the event list pointers get corrupted, - * with the result that events queued immediately thereafter get lost. - * Therefore we daren't tell Tcl_DeleteEvents to actually delete anything! - * We simply use it as a way of scanning the event queue. Events matching - * the about-to-be-deleted connid are marked dead by setting their connid - * fields to NULL. Then Pg_Notify_EventProc will do nothing when those - * events are executed. - */ -static int -NotifyEventDeleteProc(Tcl_Event *evPtr, ClientData clientData) -{ - Pg_ConnectionId *connid = (Pg_ConnectionId *) clientData; - - if (evPtr->proc == Pg_Notify_EventProc) - { - NotifyEvent *event = (NotifyEvent *) evPtr; - - if (event->connid == connid && event->notify != NULL) - event->connid = NULL; - } - return 0; -} - -/* This version deletes on-connection-loss events too */ -static int -AllNotifyEventDeleteProc(Tcl_Event *evPtr, ClientData clientData) -{ - Pg_ConnectionId *connid = (Pg_ConnectionId *) clientData; - - if (evPtr->proc == Pg_Notify_EventProc) - { - NotifyEvent *event = (NotifyEvent *) evPtr; - - if (event->connid == connid) - event->connid = NULL; - } - return 0; -} - -/* - * File handler callback: called when Tcl has detected read-ready on socket. - * The clientData is a pointer to the associated connection. - * We can ignore the condition mask since we only ever ask about read-ready. - */ - -static void -Pg_Notify_FileHandler(ClientData clientData, int mask) -{ - Pg_ConnectionId *connid = (Pg_ConnectionId *) clientData; - - /* - * Consume any data available from the SQL server (this just buffers - * it internally to libpq; but it will clear the read-ready - * condition). - */ - if (PQconsumeInput(connid->conn)) - { - /* Transfer notify events from libpq to Tcl event queue. */ - PgNotifyTransferEvents(connid); - } - else - { - /* - * If there is no input but we have read-ready, assume this means - * we lost the connection. - */ - PgConnLossTransferEvents(connid); - } -} - - -/* - * Start and stop the notify event source for a connection. - * - * We do not bother to run the notifier unless at least one pg_listen - * or pg_on_connection_loss has been executed on the connection. Currently, - * once started the notifier is run until the connection is closed. - * - * FIXME: if PQreset is executed on the underlying PGconn, the active - * socket number could change. How and when should we test for this - * and update the Tcl file handler linkage? (For that matter, we'd - * also have to reissue LISTEN commands for active LISTENs, since the - * new backend won't know about 'em. I'm leaving this problem for - * another day.) - */ - -void -PgStartNotifyEventSource(Pg_ConnectionId * connid) -{ - /* Start the notify event source if it isn't already running */ - if (!connid->notifier_running) - { - int pqsock = PQsocket(connid->conn); - - if (pqsock >= 0) - { -#if TCL_MAJOR_VERSION >= 8 - Tcl_CreateChannelHandler(connid->notifier_channel, - TCL_READABLE, - Pg_Notify_FileHandler, - (ClientData) connid); -#else - /* In Tcl 7.5 and 7.6, we need to gin up a Tcl_File. */ - Tcl_File tclfile = Tcl_GetFile((ClientData) pqsock, TCL_UNIX_FD); - - Tcl_CreateFileHandler(tclfile, TCL_READABLE, - Pg_Notify_FileHandler, (ClientData) connid); - connid->notifier_socket = pqsock; -#endif - connid->notifier_running = 1; - } - } -} - -void -PgStopNotifyEventSource(Pg_ConnectionId * connid, bool allevents) -{ - /* Remove the event source */ - if (connid->notifier_running) - { -#if TCL_MAJOR_VERSION >= 8 - Tcl_DeleteChannelHandler(connid->notifier_channel, - Pg_Notify_FileHandler, - (ClientData) connid); -#else - /* In Tcl 7.5 and 7.6, we need to gin up a Tcl_File. */ - Tcl_File tclfile = Tcl_GetFile((ClientData) connid->notifier_socket, - TCL_UNIX_FD); - - Tcl_DeleteFileHandler(tclfile); -#endif - connid->notifier_running = 0; - } - - /* Kill queued Tcl events that reference this channel */ - if (allevents) - Tcl_DeleteEvents(AllNotifyEventDeleteProc, (ClientData) connid); - else - Tcl_DeleteEvents(NotifyEventDeleteProc, (ClientData) connid); -} diff --git a/src/interfaces/libpgtcl/pgtclId.h b/src/interfaces/libpgtcl/pgtclId.h deleted file mode 100644 index fd5006bcad..0000000000 --- a/src/interfaces/libpgtcl/pgtclId.h +++ /dev/null @@ -1,64 +0,0 @@ -/*------------------------------------------------------------------------- - * - * pgtclId.h - * - * Contains Tcl "channel" interface routines, plus useful routines - * to convert between strings and pointers. These are needed because - * everything in Tcl is a string, but in C, pointers to data structures - * are needed. - * - * Portions Copyright (c) 1996-2003, PostgreSQL Global Development Group - * Portions Copyright (c) 1994, Regents of the University of California - * - * $PostgreSQL: pgsql/src/interfaces/libpgtcl/pgtclId.h,v 1.25 2003/11/29 22:41:25 pgsql Exp $ - * - *------------------------------------------------------------------------- - */ - -extern void PgSetConnectionId(Tcl_Interp *interp, PGconn *conn); - -#if TCL_MAJOR_VERSION == 7 && TCL_MINOR_VERSION == 5 -/* Only Tcl 7.5 had drivers with this signature */ -#define DRIVER_DEL_PROTO ClientData cData, Tcl_Interp *interp, \ - Tcl_File inFile, Tcl_File outFile -#define DRIVER_OUTPUT_PROTO ClientData cData, Tcl_File outFile, char *buf, \ - int bufSize, int *errorCodePtr -#define DRIVER_INPUT_PROTO ClientData cData, Tcl_File inFile, char *buf, \ - int bufSize, int *errorCodePtr -#else -/* Tcl 7.6 and beyond use this signature */ -#define DRIVER_OUTPUT_PROTO ClientData cData, CONST84 char *buf, int bufSize, \ - int *errorCodePtr -#define DRIVER_INPUT_PROTO ClientData cData, char *buf, int bufSize, \ - int *errorCodePtr -#define DRIVER_DEL_PROTO ClientData cData, Tcl_Interp *interp -#endif - -extern PGconn *PgGetConnectionId(Tcl_Interp *interp, CONST84 char *id, - Pg_ConnectionId **); -extern int PgDelConnectionId(DRIVER_DEL_PROTO); -extern int PgOutputProc(DRIVER_OUTPUT_PROTO); -extern int PgInputProc(DRIVER_INPUT_PROTO); -extern int PgSetResultId(Tcl_Interp *interp, CONST84 char *connid, - PGresult *res); -extern PGresult *PgGetResultId(Tcl_Interp *interp, CONST84 char *id); -extern void PgDelResultId(Tcl_Interp *interp, CONST84 char *id); -extern int PgGetConnByResultId(Tcl_Interp *interp, CONST84 char *resid); -extern void PgStartNotifyEventSource(Pg_ConnectionId * connid); -extern void PgStopNotifyEventSource(Pg_ConnectionId * connid, bool allevents); -extern void PgNotifyTransferEvents(Pg_ConnectionId * connid); -extern void PgConnLossTransferEvents(Pg_ConnectionId * connid); -extern void PgNotifyInterpDelete(ClientData clientData, Tcl_Interp *interp); - -/* GetFileProc is needed in Tcl 7.6 *only* ... it went away again in 8.0 */ -#if TCL_MAJOR_VERSION == 7 && TCL_MINOR_VERSION >= 6 -#define HAVE_TCL_GETFILEPROC 1 -#else -#define HAVE_TCL_GETFILEPROC 0 -#endif - -#if HAVE_TCL_GETFILEPROC -extern Tcl_File PgGetFileProc(ClientData cData, int direction); -#endif - -extern Tcl_ChannelType Pg_ConnType; diff --git a/src/interfaces/libpgtcl/win32.mak b/src/interfaces/libpgtcl/win32.mak deleted file mode 100644 index 3146067508..0000000000 --- a/src/interfaces/libpgtcl/win32.mak +++ /dev/null @@ -1,201 +0,0 @@ -# Microsoft Developer Studio Generated NMAKE File, Based on libpgtcl_REL7_1_STABLE.dsp -!IF "$(CFG)" == "" -CFG=libpgtcl - Win32 Release -!MESSAGE No configuration specified. Defaulting to libpgtcl - Win32 Release. -!ENDIF - -!IF "$(CFG)" != "libpgtcl - Win32 Release" && "$(CFG)" != "libpgtcl - Win32 Debug" -!MESSAGE Invalid configuration "$(CFG)" specified. -!MESSAGE You can specify a configuration when running NMAKE -!MESSAGE by defining the macro CFG on the command line. For example: -!MESSAGE -!MESSAGE NMAKE /f "libpgtcl.mak" CFG="libpgtcl - Win32 Debug" -!MESSAGE -!MESSAGE Possible choices for configuration are: -!MESSAGE -!MESSAGE "libpgtcl - Win32 Release" (based on "Win32 (x86) Dynamic-Link Library") -!MESSAGE "libpgtcl - Win32 Debug" (based on "Win32 (x86) Dynamic-Link Library") -!MESSAGE -!ERROR An invalid configuration is specified. -!ENDIF - -!IF "$(OS)" == "Windows_NT" -NULL= -!ELSE -NULL=nul -!ENDIF - -CPP=cl.exe -MTL=midl.exe -RSC=rc.exe - -TCLBASE=\usr\local\tcltk833 -PGINCLUDE=/I ..\..\include /I ..\libpq /I $(TCLBASE)\include - -!IF "$(CFG)" == "libpgtcl - Win32 Release" - -OUTDIR=.\Release -INTDIR=.\Release -# Begin Custom Macros -OutDir=.\Release -# End Custom Macros - -ALL : "$(OUTDIR)\libpgtcl.dll" "$(OUTDIR)\libpgtcl.bsc" - - -CLEAN : - -@erase "$(INTDIR)\pgtcl.obj" - -@erase "$(INTDIR)\pgtcl.sbr" - -@erase "$(INTDIR)\pgtclCmds.obj" - -@erase "$(INTDIR)\pgtclCmds.sbr" - -@erase "$(INTDIR)\pgtclId.obj" - -@erase "$(INTDIR)\pgtclId.sbr" - -@erase "$(INTDIR)\vc60.idb" - -@erase "$(OUTDIR)\libpgtcl.dll" - -@erase "$(OUTDIR)\libpgtcl.exp" - -@erase "$(OUTDIR)\libpgtcl.lib" - -@erase "$(OUTDIR)\libpgtcl.bsc" - -"$(OUTDIR)" : - if not exist "$(OUTDIR)/$(NULL)" mkdir "$(OUTDIR)" - -CPP_PROJ=/nologo /MT /W3 /GX /O2 $(PGINCLUDE) /D "WIN32" /D "NDEBUG" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /FR"$(INTDIR)\\" /Fp"$(INTDIR)\libpgtcl.pch" /YX /Fo"$(INTDIR)\\" /Fd"$(INTDIR)\\" /FD /c -MTL_PROJ=/nologo /D "NDEBUG" /mktyplib203 /win32 -BSC32=bscmake.exe -BSC32_FLAGS=/nologo /o"$(OUTDIR)\libpgtcl.bsc" -BSC32_SBRS= \ - "$(INTDIR)\pgtcl.sbr" \ - "$(INTDIR)\pgtclCmds.sbr" \ - "$(INTDIR)\pgtclId.sbr" - -"$(OUTDIR)\libpgtcl.bsc" : "$(OUTDIR)" $(BSC32_SBRS) - $(BSC32) @<< - $(BSC32_FLAGS) $(BSC32_SBRS) -<< - -LINK32=link.exe -LINK32_FLAGS=kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib tcl83.lib libpq.lib /nologo /dll /incremental:no /pdb:"$(OUTDIR)\libpgtcl.pdb" /machine:I386 /def:".\libpgtcl.def" /out:"$(OUTDIR)\libpgtcl.dll" /implib:"$(OUTDIR)\libpgtcl.lib" /libpath:"$(TCLBASE)\lib" /libpath:"..\libpq\Release" -DEF_FILE= \ - ".\libpgtcl.def" -LINK32_OBJS= \ - "$(INTDIR)\pgtcl.obj" \ - "$(INTDIR)\pgtclCmds.obj" \ - "$(INTDIR)\pgtclId.obj" - -"$(OUTDIR)\libpgtcl.dll" : "$(OUTDIR)" $(DEF_FILE) $(LINK32_OBJS) - $(LINK32) @<< - $(LINK32_FLAGS) $(LINK32_OBJS) -<< - -!ELSEIF "$(CFG)" == "libpgtcl - Win32 Debug" - -OUTDIR=.\Debug -INTDIR=.\Debug -# Begin Custom Macros -OutDir=.\Debug -# End Custom Macros - -ALL : "$(OUTDIR)\libpgtcl.dll" "$(OUTDIR)\libpgtcl.bsc" - - -CLEAN : - -@erase "$(INTDIR)\pgtcl.obj" - -@erase "$(INTDIR)\pgtcl.sbr" - -@erase "$(INTDIR)\pgtclCmds.obj" - -@erase "$(INTDIR)\pgtclCmds.sbr" - -@erase "$(INTDIR)\pgtclId.obj" - -@erase "$(INTDIR)\pgtclId.sbr" - -@erase "$(INTDIR)\vc60.idb" - -@erase "$(INTDIR)\vc60.pdb" - -@erase "$(OUTDIR)\libpgtcl.dll" - -@erase "$(OUTDIR)\libpgtcl.exp" - -@erase "$(OUTDIR)\libpgtcl.ilk" - -@erase "$(OUTDIR)\libpgtcl.lib" - -@erase "$(OUTDIR)\libpgtcl.pdb" - -@erase "$(OUTDIR)\libpgtcl.bsc" - -"$(OUTDIR)" : - if not exist "$(OUTDIR)/$(NULL)" mkdir "$(OUTDIR)" - -CPP_PROJ=/nologo /MTd /W3 /Gm /GX /ZI /Od $(PGINCLUDE) /D "WIN32" /D "_DEBUG" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /FR"$(INTDIR)\\" /Fp"$(INTDIR)\libpgtcl.pch" /YX /Fo"$(INTDIR)\\" /Fd"$(INTDIR)\\" /FD /GZ /c -MTL_PROJ=/nologo /D "_DEBUG" /mktyplib203 /win32 -BSC32=bscmake.exe -BSC32_FLAGS=/nologo /o"$(OUTDIR)\libpgtcl.bsc" -BSC32_SBRS= \ - "$(INTDIR)\pgtcl.sbr" \ - "$(INTDIR)\pgtclCmds.sbr" \ - "$(INTDIR)\pgtclId.sbr" - -"$(OUTDIR)\libpgtcl.bsc" : "$(OUTDIR)" $(BSC32_SBRS) - $(BSC32) @<< - $(BSC32_FLAGS) $(BSC32_SBRS) -<< - -LINK32=link.exe -LINK32_FLAGS=tcl83.lib libpq.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /dll /incremental:yes /pdb:"$(OUTDIR)\libpgtcl.pdb" /debug /machine:I386 /def:".\libpgtcl.def" /out:"$(OUTDIR)\libpgtcl.dll" /implib:"$(OUTDIR)\libpgtcl.lib" /pdbtype:sept /libpath:"$(TCLBASE)\lib" /libpath:"..\libpq\Debug" -DEF_FILE= \ - ".\libpgtcl.def" -LINK32_OBJS= \ - "$(INTDIR)\pgtcl.obj" \ - "$(INTDIR)\pgtclCmds.obj" \ - "$(INTDIR)\pgtclId.obj" - -"$(OUTDIR)\libpgtcl.dll" : "$(OUTDIR)" $(DEF_FILE) $(LINK32_OBJS) - $(LINK32) @<< - $(LINK32_FLAGS) $(LINK32_OBJS) -<< - -!ENDIF - -.c{$(INTDIR)}.obj:: - $(CPP) @<< - $(CPP_PROJ) $< -<< - -.cpp{$(INTDIR)}.obj:: - $(CPP) @<< - $(CPP_PROJ) $< -<< - -.cxx{$(INTDIR)}.obj:: - $(CPP) @<< - $(CPP_PROJ) $< -<< - -.c{$(INTDIR)}.sbr:: - $(CPP) @<< - $(CPP_PROJ) $< -<< - -.cpp{$(INTDIR)}.sbr:: - $(CPP) @<< - $(CPP_PROJ) $< -<< - -.cxx{$(INTDIR)}.sbr:: - $(CPP) @<< - $(CPP_PROJ) $< -<< - -!IF "$(CFG)" == "libpgtcl - Win32 Release" || "$(CFG)" == "libpgtcl - Win32 Debug" -SOURCE=pgtcl.c - -"$(INTDIR)\pgtcl.obj" "$(INTDIR)\pgtcl.sbr" : $(SOURCE) "$(INTDIR)" - $(CPP) $(CPP_PROJ) $(SOURCE) - - -SOURCE=pgtclCmds.c - -"$(INTDIR)\pgtclCmds.obj" "$(INTDIR)\pgtclCmds.sbr" : $(SOURCE) "$(INTDIR)" - $(CPP) $(CPP_PROJ) $(SOURCE) - - -SOURCE=pgtclId.c - -"$(INTDIR)\pgtclId.obj" "$(INTDIR)\pgtclId.sbr" : $(SOURCE) "$(INTDIR)" - $(CPP) $(CPP_PROJ) $(SOURCE) - - - -!ENDIF - -- GitLab