#
# 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 =
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
--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
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.
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)
#
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
#
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
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
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
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)
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
#
# -*-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,
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@
# 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 $
#
#-------------------------------------------------------------------------
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
+++ /dev/null
-#-------------------------------------------------------------------------
-#
-# 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
+++ /dev/null
-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.
+++ /dev/null
-/*
- * 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 <tcl.h>
-
-#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;
-}
+++ /dev/null
-# 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
-}
-
+++ /dev/null
-/*
- * 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 <tk.h>
-#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;
-}
+++ /dev/null
-#
-# 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
-}
-
#
# 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 $
#
#-------------------------------------------------------------------------
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
+++ /dev/null
-#-------------------------------------------------------------------------
-#
-# 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
+++ /dev/null
-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}.<result#>.
- 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 <table> from stdin" or
- "copy <table> 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.
+++ /dev/null
-;libpgtcl.def\r
-; The LIBRARY entry must be same as the name of your DLL, the name of \r
-; our DLL is libpgtcl.dll\r
-LIBRARY libpgtcl\r
-EXPORTS \r
- \r
- Pgtcl_Init \r
- Pgtcl_SafeInit\r
+++ /dev/null
-/*-------------------------------------------------------------------------
- *
- * 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 <tcl.h>
-
-extern int Pgtcl_Init(Tcl_Interp *interp);
-extern int Pgtcl_SafeInit(Tcl_Interp *interp);
-
-#endif /* LIBPGTCL_H */
+++ /dev/null
-/*-------------------------------------------------------------------------
- *
- * 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);
-}
+++ /dev/null
-/*-------------------------------------------------------------------------
- *
- * 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 <ctype.h>
-
-#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;
-}
+++ /dev/null
-/*-------------------------------------------------------------------------
- *
- * 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 <tcl.h>
-
-#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 */
+++ /dev/null
-/*-------------------------------------------------------------------------
- *
- * 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 <errno.h>
-
-#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 <rel> 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 <rel> 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);
-}
+++ /dev/null
-/*-------------------------------------------------------------------------
- *
- * 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;
+++ /dev/null
-# Microsoft Developer Studio Generated NMAKE File, Based on libpgtcl_REL7_1_STABLE.dsp\r
-!IF "$(CFG)" == ""\r
-CFG=libpgtcl - Win32 Release\r
-!MESSAGE No configuration specified. Defaulting to libpgtcl - Win32 Release.\r
-!ENDIF \r
-\r
-!IF "$(CFG)" != "libpgtcl - Win32 Release" && "$(CFG)" != "libpgtcl - Win32 Debug"\r
-!MESSAGE Invalid configuration "$(CFG)" specified.\r
-!MESSAGE You can specify a configuration when running NMAKE\r
-!MESSAGE by defining the macro CFG on the command line. For example:\r
-!MESSAGE \r
-!MESSAGE NMAKE /f "libpgtcl.mak" CFG="libpgtcl - Win32 Debug"\r
-!MESSAGE \r
-!MESSAGE Possible choices for configuration are:\r
-!MESSAGE \r
-!MESSAGE "libpgtcl - Win32 Release" (based on "Win32 (x86) Dynamic-Link Library")\r
-!MESSAGE "libpgtcl - Win32 Debug" (based on "Win32 (x86) Dynamic-Link Library")\r
-!MESSAGE \r
-!ERROR An invalid configuration is specified.\r
-!ENDIF \r
-\r
-!IF "$(OS)" == "Windows_NT"\r
-NULL=\r
-!ELSE \r
-NULL=nul\r
-!ENDIF \r
-\r
-CPP=cl.exe\r
-MTL=midl.exe\r
-RSC=rc.exe\r
-\r
-TCLBASE=\usr\local\tcltk833\r
-PGINCLUDE=/I ..\..\include /I ..\libpq /I $(TCLBASE)\include\r
-\r
-!IF "$(CFG)" == "libpgtcl - Win32 Release"\r
-\r
-OUTDIR=.\Release\r
-INTDIR=.\Release\r
-# Begin Custom Macros\r
-OutDir=.\Release\r
-# End Custom Macros\r
-\r
-ALL : "$(OUTDIR)\libpgtcl.dll" "$(OUTDIR)\libpgtcl.bsc"\r
-\r
-\r
-CLEAN :\r
- -@erase "$(INTDIR)\pgtcl.obj"\r
- -@erase "$(INTDIR)\pgtcl.sbr"\r
- -@erase "$(INTDIR)\pgtclCmds.obj"\r
- -@erase "$(INTDIR)\pgtclCmds.sbr"\r
- -@erase "$(INTDIR)\pgtclId.obj"\r
- -@erase "$(INTDIR)\pgtclId.sbr"\r
- -@erase "$(INTDIR)\vc60.idb"\r
- -@erase "$(OUTDIR)\libpgtcl.dll"\r
- -@erase "$(OUTDIR)\libpgtcl.exp"\r
- -@erase "$(OUTDIR)\libpgtcl.lib"\r
- -@erase "$(OUTDIR)\libpgtcl.bsc"\r
-\r
-"$(OUTDIR)" :\r
- if not exist "$(OUTDIR)/$(NULL)" mkdir "$(OUTDIR)"\r
-\r
-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 \r
-MTL_PROJ=/nologo /D "NDEBUG" /mktyplib203 /win32 \r
-BSC32=bscmake.exe\r
-BSC32_FLAGS=/nologo /o"$(OUTDIR)\libpgtcl.bsc" \r
-BSC32_SBRS= \\r
- "$(INTDIR)\pgtcl.sbr" \\r
- "$(INTDIR)\pgtclCmds.sbr" \\r
- "$(INTDIR)\pgtclId.sbr"\r
-\r
-"$(OUTDIR)\libpgtcl.bsc" : "$(OUTDIR)" $(BSC32_SBRS)\r
- $(BSC32) @<<\r
- $(BSC32_FLAGS) $(BSC32_SBRS)\r
-<<\r
-\r
-LINK32=link.exe\r
-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" \r
-DEF_FILE= \\r
- ".\libpgtcl.def"\r
-LINK32_OBJS= \\r
- "$(INTDIR)\pgtcl.obj" \\r
- "$(INTDIR)\pgtclCmds.obj" \\r
- "$(INTDIR)\pgtclId.obj"\r
-\r
-"$(OUTDIR)\libpgtcl.dll" : "$(OUTDIR)" $(DEF_FILE) $(LINK32_OBJS)\r
- $(LINK32) @<<\r
- $(LINK32_FLAGS) $(LINK32_OBJS)\r
-<<\r
-\r
-!ELSEIF "$(CFG)" == "libpgtcl - Win32 Debug"\r
-\r
-OUTDIR=.\Debug\r
-INTDIR=.\Debug\r
-# Begin Custom Macros\r
-OutDir=.\Debug\r
-# End Custom Macros\r
-\r
-ALL : "$(OUTDIR)\libpgtcl.dll" "$(OUTDIR)\libpgtcl.bsc"\r
-\r
-\r
-CLEAN :\r
- -@erase "$(INTDIR)\pgtcl.obj"\r
- -@erase "$(INTDIR)\pgtcl.sbr"\r
- -@erase "$(INTDIR)\pgtclCmds.obj"\r
- -@erase "$(INTDIR)\pgtclCmds.sbr"\r
- -@erase "$(INTDIR)\pgtclId.obj"\r
- -@erase "$(INTDIR)\pgtclId.sbr"\r
- -@erase "$(INTDIR)\vc60.idb"\r
- -@erase "$(INTDIR)\vc60.pdb"\r
- -@erase "$(OUTDIR)\libpgtcl.dll"\r
- -@erase "$(OUTDIR)\libpgtcl.exp"\r
- -@erase "$(OUTDIR)\libpgtcl.ilk"\r
- -@erase "$(OUTDIR)\libpgtcl.lib"\r
- -@erase "$(OUTDIR)\libpgtcl.pdb"\r
- -@erase "$(OUTDIR)\libpgtcl.bsc"\r
-\r
-"$(OUTDIR)" :\r
- if not exist "$(OUTDIR)/$(NULL)" mkdir "$(OUTDIR)"\r
-\r
-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 \r
-MTL_PROJ=/nologo /D "_DEBUG" /mktyplib203 /win32 \r
-BSC32=bscmake.exe\r
-BSC32_FLAGS=/nologo /o"$(OUTDIR)\libpgtcl.bsc" \r
-BSC32_SBRS= \\r
- "$(INTDIR)\pgtcl.sbr" \\r
- "$(INTDIR)\pgtclCmds.sbr" \\r
- "$(INTDIR)\pgtclId.sbr"\r
-\r
-"$(OUTDIR)\libpgtcl.bsc" : "$(OUTDIR)" $(BSC32_SBRS)\r
- $(BSC32) @<<\r
- $(BSC32_FLAGS) $(BSC32_SBRS)\r
-<<\r
-\r
-LINK32=link.exe\r
-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" \r
-DEF_FILE= \\r
- ".\libpgtcl.def"\r
-LINK32_OBJS= \\r
- "$(INTDIR)\pgtcl.obj" \\r
- "$(INTDIR)\pgtclCmds.obj" \\r
- "$(INTDIR)\pgtclId.obj"\r
-\r
-"$(OUTDIR)\libpgtcl.dll" : "$(OUTDIR)" $(DEF_FILE) $(LINK32_OBJS)\r
- $(LINK32) @<<\r
- $(LINK32_FLAGS) $(LINK32_OBJS)\r
-<<\r
-\r
-!ENDIF \r
-\r
-.c{$(INTDIR)}.obj::\r
- $(CPP) @<<\r
- $(CPP_PROJ) $< \r
-<<\r
-\r
-.cpp{$(INTDIR)}.obj::\r
- $(CPP) @<<\r
- $(CPP_PROJ) $< \r
-<<\r
-\r
-.cxx{$(INTDIR)}.obj::\r
- $(CPP) @<<\r
- $(CPP_PROJ) $< \r
-<<\r
-\r
-.c{$(INTDIR)}.sbr::\r
- $(CPP) @<<\r
- $(CPP_PROJ) $< \r
-<<\r
-\r
-.cpp{$(INTDIR)}.sbr::\r
- $(CPP) @<<\r
- $(CPP_PROJ) $< \r
-<<\r
-\r
-.cxx{$(INTDIR)}.sbr::\r
- $(CPP) @<<\r
- $(CPP_PROJ) $< \r
-<<\r
-\r
-!IF "$(CFG)" == "libpgtcl - Win32 Release" || "$(CFG)" == "libpgtcl - Win32 Debug"\r
-SOURCE=pgtcl.c\r
-\r
-"$(INTDIR)\pgtcl.obj" "$(INTDIR)\pgtcl.sbr" : $(SOURCE) "$(INTDIR)"\r
- $(CPP) $(CPP_PROJ) $(SOURCE)\r
-\r
-\r
-SOURCE=pgtclCmds.c\r
-\r
-"$(INTDIR)\pgtclCmds.obj" "$(INTDIR)\pgtclCmds.sbr" : $(SOURCE) "$(INTDIR)"\r
- $(CPP) $(CPP_PROJ) $(SOURCE)\r
-\r
-\r
-SOURCE=pgtclId.c\r
-\r
-"$(INTDIR)\pgtclId.obj" "$(INTDIR)\pgtclId.sbr" : $(SOURCE) "$(INTDIR)"\r
- $(CPP) $(CPP_PROJ) $(SOURCE)\r
-\r
-\r
-\r
-!ENDIF \r
-\r
projects / postgresql / commitdiff