Skip to content

P
Postgres FD Implementation
Commit 41fa9e9b authored by PostgreSQL Daemon's avatar PostgreSQL Daemon
Browse files
Options

Remove all of the libpgtcl and pgtclsh files, including all references to 

them within the various makefiles

with_tcl is still required for the src/pl/tcl language
parent d1b3915c
Hide whitespace changes
Inline Side-by-side
Showing with 8 additions and 4186 deletions
GNUmakefile.in
View file @ 41fa9e9b
#
# PostgreSQL top level makefile
#
# $PostgreSQL: pgsql/GNUmakefile.in,v 1.37 2004/01/19 21:20:04 tgl Exp $
# $PostgreSQL: pgsql/GNUmakefile.in,v 1.38 2004/04/20 00:33:44 pgsql Exp $
#
subdir =
......@@ -71,8 +71,6 @@ $(distdir).tar: distdir
opt_files := \
src/tools src/corba src/tutorial \
src/bin/pgtclsh \
$(addprefix src/interfaces/, libpgtcl) \
$(addprefix src/pl/, plperl plpython tcl)
docs_files := doc/postgres.tar.gz doc/src doc/TODO.detail
......
configure
View file @ 41fa9e9b
......@@ -859,9 +859,7 @@ Optional Packages:
--with-libs=DIRS alternative spelling of --with-libraries
--with-pgport=PORTNUM change default port number 5432
--with-tcl build Tcl and Tk interfaces
--without-tk do not build Tk interfaces if Tcl is enabled
--with-tclconfig=DIR tclConfig.sh and tkConfig.sh are in DIR
--with-tkconfig=DIR tkConfig.sh is in DIR
--with-tclconfig=DIR tclConfig.sh is in DIR
--with-perl build Perl modules (PL/Perl)
--with-python build Python modules (PL/Python)
--with-krb4 build with Kerberos 4 support
......@@ -2999,44 +2997,6 @@ echo "$as_me:$LINENO: result: $with_tcl" >&5
echo "${ECHO_T}$with_tcl" >&6
# If Tcl is enabled (above) then Tk is also, unless the user disables it using --without-tk
echo "$as_me:$LINENO: checking whether to build with Tk" >&5
echo $ECHO_N "checking whether to build with Tk... $ECHO_C" >&6
if test "$with_tcl" = yes; then
# Check whether --with-tk or --without-tk was given.
if test "${with_tk+set}" = set; then
withval="$with_tk"
case $withval in
yes)
:
;;
no)
:
;;
*)
{ { echo "$as_me:$LINENO: error: no argument expected for --with-tk option" >&5
echo "$as_me: error: no argument expected for --with-tk option" >&2;}
{ (exit 1); exit 1; }; }
;;
esac
else
with_tk=yes
fi;
else
with_tk=no
fi
echo "$as_me:$LINENO: result: $with_tk" >&5
echo "${ECHO_T}$with_tk" >&6
# We see if the path to the Tcl/Tk configuration scripts is specified.
# This will override the use of tclsh to find the paths to search.
......@@ -3066,35 +3026,6 @@ echo "$as_me: error: argument required for --with-tclconfig option" >&2;}
fi;
# We see if the path to the Tk configuration scripts is specified.
# This will override the use of tclsh to find the paths to search.
# Check whether --with-tkconfig or --without-tkconfig was given.
if test "${with_tkconfig+set}" = set; then
withval="$with_tkconfig"
case $withval in
yes)
{ { echo "$as_me:$LINENO: error: argument required for --with-tkconfig option" >&5
echo "$as_me: error: argument required for --with-tkconfig option" >&2;}
{ (exit 1); exit 1; }; }
;;
no)
{ { echo "$as_me:$LINENO: error: argument required for --with-tkconfig option" >&5
echo "$as_me: error: argument required for --with-tkconfig option" >&2;}
{ (exit 1); exit 1; }; }
;;
*)
;;
esac
fi;
#
# Optionally build Perl modules (PL/Perl)
#
......@@ -17233,51 +17164,6 @@ eval TCL_SHARED_BUILD=\"$TCL_SHARED_BUILD\"
fi
# Check for Tk configuration script tkConfig.sh
if test "$with_tk" = yes; then
echo "$as_me:$LINENO: checking for tkConfig.sh" >&5
echo $ECHO_N "checking for tkConfig.sh... $ECHO_C" >&6
# Let user override test
if test -z "$TK_CONFIG_SH"; then
pgac_test_dirs="$with_tkconfig $with_tclconfig"
set X $pgac_test_dirs; shift
if test $# -eq 0; then
test -z "$TCLSH" && { { echo "$as_me:$LINENO: error: unable to locate tkConfig.sh because no Tcl shell was found" >&5
echo "$as_me: error: unable to locate tkConfig.sh because no Tcl shell was found" >&2;}
{ (exit 1); exit 1; }; }
set X `echo 'puts $auto_path' | $TCLSH`; shift
fi
for pgac_dir do
if test -r "$pgac_dir/tkConfig.sh"; then
TK_CONFIG_SH=$pgac_dir/tkConfig.sh
break
fi
done
fi
if test -z "$TK_CONFIG_SH"; then
echo "$as_me:$LINENO: result: no" >&5
echo "${ECHO_T}no" >&6
{ { echo "$as_me:$LINENO: error: file 'tkConfig.sh' is required for Tk" >&5
echo "$as_me: error: file 'tkConfig.sh' is required for Tk" >&2;}
{ (exit 1); exit 1; }; }
else
echo "$as_me:$LINENO: result: $TK_CONFIG_SH" >&5
echo "${ECHO_T}$TK_CONFIG_SH" >&6
fi
. "$TK_CONFIG_SH"
eval TK_LIBS=\"$TK_LIBS\"
eval TK_LIB_SPEC=\"$TK_LIB_SPEC\"
eval TK_XINCLUDES=\"$TK_XINCLUDES\"
fi
#
# Check for DocBook and tools
#
......@@ -18197,7 +18083,6 @@ s,@autodepend@,$autodepend,;t t
s,@INCLUDES@,$INCLUDES,;t t
s,@enable_thread_safety@,$enable_thread_safety,;t t
s,@with_tcl@,$with_tcl,;t t
s,@with_tk@,$with_tk,;t t
s,@with_perl@,$with_perl,;t t
s,@with_python@,$with_python,;t t
s,@with_krb4@,$with_krb4,;t t
......@@ -18253,10 +18138,6 @@ s,@TCL_LIBS@,$TCL_LIBS,;t t
s,@TCL_LIB_SPEC@,$TCL_LIB_SPEC,;t t
s,@TCL_SHARED_BUILD@,$TCL_SHARED_BUILD,;t t
s,@TCL_SHLIB_LD_LIBS@,$TCL_SHLIB_LD_LIBS,;t t
s,@TK_CONFIG_SH@,$TK_CONFIG_SH,;t t
s,@TK_LIBS@,$TK_LIBS,;t t
s,@TK_LIB_SPEC@,$TK_LIB_SPEC,;t t
s,@TK_XINCLUDES@,$TK_XINCLUDES,;t t
s,@NSGMLS@,$NSGMLS,;t t
s,@JADE@,$JADE,;t t
s,@have_docbook@,$have_docbook,;t t
......
configure.in
View file @ 41fa9e9b
dnl Process this file with autoconf to produce a configure script.
dnl $PostgreSQL: pgsql/configure.in,v 1.322 2004/03/24 03:54:16 momjian Exp $
dnl $PostgreSQL: pgsql/configure.in,v 1.323 2004/04/20 00:33:45 pgsql Exp $
dnl
dnl Developers, please strive to achieve this order:
dnl
......@@ -372,26 +372,10 @@ PGAC_ARG_BOOL(with, tcl, no, [ --with-tcl build Tcl and Tk interfa
AC_MSG_RESULT([$with_tcl])
AC_SUBST([with_tcl])
# If Tcl is enabled (above) then Tk is also, unless the user disables it using --without-tk
AC_MSG_CHECKING([whether to build with Tk])
if test "$with_tcl" = yes; then
PGAC_ARG_BOOL(with, tk, yes, [ --without-tk do not build Tk interfaces if Tcl is enabled])
else
with_tk=no
fi
AC_MSG_RESULT([$with_tk])
AC_SUBST([with_tk])
# We see if the path to the Tcl/Tk configuration scripts is specified.
# This will override the use of tclsh to find the paths to search.
PGAC_ARG_REQ(with, tclconfig, [ --with-tclconfig=DIR tclConfig.sh and tkConfig.sh are in DIR])
# We see if the path to the Tk configuration scripts is specified.
# This will override the use of tclsh to find the paths to search.
PGAC_ARG_REQ(with, tkconfig, [ --with-tkconfig=DIR tkConfig.sh is in DIR])
PGAC_ARG_REQ(with, tclconfig, [ --with-tclconfig=DIR tclConfig.sh is in DIR])
#
# Optionally build Perl modules (PL/Perl)
......@@ -1189,13 +1173,6 @@ if test "$with_tcl" = yes; then
AC_SUBST(TCL_SHLIB_LD_LIBS)dnl don't want to double-evaluate that one
fi
# Check for Tk configuration script tkConfig.sh
if test "$with_tk" = yes; then
PGAC_PATH_TKCONFIGSH([$with_tkconfig $with_tclconfig])
PGAC_EVAL_TCLCONFIGSH([$TK_CONFIG_SH], [TK_LIBS,TK_LIB_SPEC,TK_XINCLUDES])
fi
#
# Check for DocBook and tools
#
......
src/Makefile.global.in
View file @ 41fa9e9b
# -*-makefile-*-
# $PostgreSQL: pgsql/src/Makefile.global.in,v 1.176 2004/03/10 21:12:46 momjian Exp $
# $PostgreSQL: pgsql/src/Makefile.global.in,v 1.177 2004/04/20 00:33:46 pgsql Exp $
#------------------------------------------------------------------------------
# All PostgreSQL makefiles include this file and use the variables it sets,
......@@ -123,7 +123,6 @@ localedir := @localedir@
with_perl = @with_perl@
with_python = @with_python@
with_tcl = @with_tcl@
with_tk = @with_tk@
enable_shared = @enable_shared@
enable_rpath = @enable_rpath@
enable_nls = @enable_nls@
......
src/bin/Makefile
View file @ 41fa9e9b
......@@ -5,7 +5,7 @@
# Portions Copyright (c) 1996-2002, PostgreSQL Global Development Group
# Portions Copyright (c) 1994, Regents of the University of California
#
# $PostgreSQL: pgsql/src/bin/Makefile,v 1.41 2003/12/17 18:44:08 petere Exp $
# $PostgreSQL: pgsql/src/bin/Makefile,v 1.42 2004/04/20 00:33:47 pgsql Exp $
#
#-------------------------------------------------------------------------
......@@ -17,10 +17,6 @@ DIRS := initdb initlocation ipcclean pg_ctl pg_dump \
psql scripts pg_config pg_controldata pg_resetxlog \
pg_encoding
ifeq ($(with_tcl), yes)
DIRS += pgtclsh
endif
all install installdirs uninstall depend distprep:
@for dir in $(DIRS); do $(MAKE) -C $$dir $@ || exit; done
......
src/bin/pgtclsh/Makefile deleted 100644 → 0
View file @ d1b3915c
#-------------------------------------------------------------------------
#
# 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
src/bin/pgtclsh/README deleted 100644 → 0
View file @ d1b3915c
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.
src/bin/pgtclsh/pgtclAppInit.c deleted 100644 → 0
View file @ d1b3915c
/*
* 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;
}
src/bin/pgtclsh/pgtclUtils.tcl deleted 100644 → 0
View file @ d1b3915c
# 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
}
src/bin/pgtclsh/pgtkAppInit.c deleted 100644 → 0
View file @ d1b3915c
/*
* 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;
}
src/bin/pgtclsh/updateStats.tcl deleted 100644 → 0
View file @ d1b3915c
#
# 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
}
src/interfaces/Makefile
View file @ 41fa9e9b
......@@ -4,7 +4,7 @@
#
# Copyright (c) 1994, Regents of the University of California
#
# $PostgreSQL: pgsql/src/interfaces/Makefile,v 1.52 2004/01/19 21:20:06 tgl Exp $
# $PostgreSQL: pgsql/src/interfaces/Makefile,v 1.53 2004/04/20 00:33:51 pgsql Exp $
#
#-------------------------------------------------------------------------
......@@ -14,12 +14,7 @@ include $(top_builddir)/src/Makefile.global
DIRS := libpq ecpg
ALLDIRS := $(DIRS) libpgtcl
ifeq ($(with_tcl), yes)
DIRS += libpgtcl
endif
ALLDIRS := $(DIRS)
all install installdirs uninstall dep depend distprep:
@for dir in $(DIRS); do $(MAKE) -C $$dir $@ || exit; done
......
src/interfaces/libpgtcl/Makefile deleted 100644 → 0
View file @ d1b3915c
#-------------------------------------------------------------------------
#
# 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
src/interfaces/libpgtcl/README deleted 100644 → 0
View file @ d1b3915c
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.
src/interfaces/libpgtcl/libpgtcl.def deleted 100644 → 0
View file @ d1b3915c
;libpgtcl.def
; The LIBRARY entry must be same as the name of your DLL, the name of
; our DLL is libpgtcl.dll
LIBRARY libpgtcl
EXPORTS
Pgtcl_Init
Pgtcl_SafeInit
src/interfaces/libpgtcl/libpgtcl.h deleted 100644 → 0
View file @ d1b3915c
/*-------------------------------------------------------------------------
*
* 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 */
src/interfaces/libpgtcl/pgtcl.c deleted 100644 → 0
View file @ d1b3915c
/*-------------------------------------------------------------------------
*
* 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);
}
src/interfaces/libpgtcl/pgtclCmds.c deleted 100644 → 0
View file @ d1b3915c
/*-------------------------------------------------------------------------
*
* 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(&notifies->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(&notifies->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(&notifies->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(&notifies->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(&notifies->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;
}
src/interfaces/libpgtcl/pgtclCmds.h deleted 100644 → 0
View file @ d1b3915c
/*-------------------------------------------------------------------------
*
* 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 */
src/interfaces/libpgtcl/pgtclId.c deleted 100644 → 0
View file @ d1b3915c
/*-------------------------------------------------------------------------
*
* 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(&notifies->notify_hash, &hsearch);
entry != NULL;
entry = Tcl_NextHashEntry(&hsearch))
ckfree((char *) Tcl_GetHashValue(entry));
Tcl_DeleteHashTable(&notifies->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(&notifies->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);
}
src/interfaces/libpgtcl/pgtclId.h deleted 100644 → 0
View file @ d1b3915c
/*-------------------------------------------------------------------------
*
* 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;
src/interfaces/libpgtcl/win32.mak deleted 100644 → 0
View file @ d1b3915c
# Microsoft Developer Studio Generated NMAKE File, Based on libpgtcl_REL7_1_STABLE.dsp
!IF "$(CFG)" == ""
CFG=libpgtcl - Win32 Release
!MESSAGE No configuration specified. Defaulting to libpgtcl - Win32 Release.
!ENDIF
!IF "$(CFG)" != "libpgtcl - Win32 Release" && "$(CFG)" != "libpgtcl - Win32 Debug"
!MESSAGE Invalid configuration "$(CFG)" specified.
!MESSAGE You can specify a configuration when running NMAKE
!MESSAGE by defining the macro CFG on the command line. For example:
!MESSAGE
!MESSAGE NMAKE /f "libpgtcl.mak" CFG="libpgtcl - Win32 Debug"
!MESSAGE
!MESSAGE Possible choices for configuration are:
!MESSAGE
!MESSAGE "libpgtcl - Win32 Release" (based on "Win32 (x86) Dynamic-Link Library")
!MESSAGE "libpgtcl - Win32 Debug" (based on "Win32 (x86) Dynamic-Link Library")
!MESSAGE
!ERROR An invalid configuration is specified.
!ENDIF
!IF "$(OS)" == "Windows_NT"
NULL=
!ELSE
NULL=nul
!ENDIF
CPP=cl.exe
MTL=midl.exe
RSC=rc.exe
TCLBASE=\usr\local\tcltk833
PGINCLUDE=/I ..\..\include /I ..\libpq /I $(TCLBASE)\include
!IF "$(CFG)" == "libpgtcl - Win32 Release"
OUTDIR=.\Release
INTDIR=.\Release
# Begin Custom Macros
OutDir=.\Release
# End Custom Macros
ALL : "$(OUTDIR)\libpgtcl.dll" "$(OUTDIR)\libpgtcl.bsc"
CLEAN :
-@erase "$(INTDIR)\pgtcl.obj"
-@erase "$(INTDIR)\pgtcl.sbr"
-@erase "$(INTDIR)\pgtclCmds.obj"
-@erase "$(INTDIR)\pgtclCmds.sbr"
-@erase "$(INTDIR)\pgtclId.obj"
-@erase "$(INTDIR)\pgtclId.sbr"
-@erase "$(INTDIR)\vc60.idb"
-@erase "$(OUTDIR)\libpgtcl.dll"
-@erase "$(OUTDIR)\libpgtcl.exp"
-@erase "$(OUTDIR)\libpgtcl.lib"
-@erase "$(OUTDIR)\libpgtcl.bsc"
"$(OUTDIR)" :
if not exist "$(OUTDIR)/$(NULL)" mkdir "$(OUTDIR)"
CPP_PROJ=/nologo /MT /W3 /GX /O2 $(PGINCLUDE) /D "WIN32" /D "NDEBUG" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /FR"$(INTDIR)\\" /Fp"$(INTDIR)\libpgtcl.pch" /YX /Fo"$(INTDIR)\\" /Fd"$(INTDIR)\\" /FD /c
MTL_PROJ=/nologo /D "NDEBUG" /mktyplib203 /win32
BSC32=bscmake.exe
BSC32_FLAGS=/nologo /o"$(OUTDIR)\libpgtcl.bsc"
BSC32_SBRS= \
"$(INTDIR)\pgtcl.sbr" \
"$(INTDIR)\pgtclCmds.sbr" \
"$(INTDIR)\pgtclId.sbr"
"$(OUTDIR)\libpgtcl.bsc" : "$(OUTDIR)" $(BSC32_SBRS)
$(BSC32) @<<
$(BSC32_FLAGS) $(BSC32_SBRS)
<<
LINK32=link.exe
LINK32_FLAGS=kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib tcl83.lib libpq.lib /nologo /dll /incremental:no /pdb:"$(OUTDIR)\libpgtcl.pdb" /machine:I386 /def:".\libpgtcl.def" /out:"$(OUTDIR)\libpgtcl.dll" /implib:"$(OUTDIR)\libpgtcl.lib" /libpath:"$(TCLBASE)\lib" /libpath:"..\libpq\Release"
DEF_FILE= \
".\libpgtcl.def"
LINK32_OBJS= \
"$(INTDIR)\pgtcl.obj" \
"$(INTDIR)\pgtclCmds.obj" \
"$(INTDIR)\pgtclId.obj"
"$(OUTDIR)\libpgtcl.dll" : "$(OUTDIR)" $(DEF_FILE) $(LINK32_OBJS)
$(LINK32) @<<
$(LINK32_FLAGS) $(LINK32_OBJS)
<<
!ELSEIF "$(CFG)" == "libpgtcl - Win32 Debug"
OUTDIR=.\Debug
INTDIR=.\Debug
# Begin Custom Macros
OutDir=.\Debug
# End Custom Macros
ALL : "$(OUTDIR)\libpgtcl.dll" "$(OUTDIR)\libpgtcl.bsc"
CLEAN :
-@erase "$(INTDIR)\pgtcl.obj"
-@erase "$(INTDIR)\pgtcl.sbr"
-@erase "$(INTDIR)\pgtclCmds.obj"
-@erase "$(INTDIR)\pgtclCmds.sbr"
-@erase "$(INTDIR)\pgtclId.obj"
-@erase "$(INTDIR)\pgtclId.sbr"
-@erase "$(INTDIR)\vc60.idb"
-@erase "$(INTDIR)\vc60.pdb"
-@erase "$(OUTDIR)\libpgtcl.dll"
-@erase "$(OUTDIR)\libpgtcl.exp"
-@erase "$(OUTDIR)\libpgtcl.ilk"
-@erase "$(OUTDIR)\libpgtcl.lib"
-@erase "$(OUTDIR)\libpgtcl.pdb"
-@erase "$(OUTDIR)\libpgtcl.bsc"
"$(OUTDIR)" :
if not exist "$(OUTDIR)/$(NULL)" mkdir "$(OUTDIR)"
CPP_PROJ=/nologo /MTd /W3 /Gm /GX /ZI /Od $(PGINCLUDE) /D "WIN32" /D "_DEBUG" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /FR"$(INTDIR)\\" /Fp"$(INTDIR)\libpgtcl.pch" /YX /Fo"$(INTDIR)\\" /Fd"$(INTDIR)\\" /FD /GZ /c
MTL_PROJ=/nologo /D "_DEBUG" /mktyplib203 /win32
BSC32=bscmake.exe
BSC32_FLAGS=/nologo /o"$(OUTDIR)\libpgtcl.bsc"
BSC32_SBRS= \
"$(INTDIR)\pgtcl.sbr" \
"$(INTDIR)\pgtclCmds.sbr" \
"$(INTDIR)\pgtclId.sbr"
"$(OUTDIR)\libpgtcl.bsc" : "$(OUTDIR)" $(BSC32_SBRS)
$(BSC32) @<<
$(BSC32_FLAGS) $(BSC32_SBRS)
<<
LINK32=link.exe
LINK32_FLAGS=tcl83.lib libpq.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /dll /incremental:yes /pdb:"$(OUTDIR)\libpgtcl.pdb" /debug /machine:I386 /def:".\libpgtcl.def" /out:"$(OUTDIR)\libpgtcl.dll" /implib:"$(OUTDIR)\libpgtcl.lib" /pdbtype:sept /libpath:"$(TCLBASE)\lib" /libpath:"..\libpq\Debug"
DEF_FILE= \
".\libpgtcl.def"
LINK32_OBJS= \
"$(INTDIR)\pgtcl.obj" \
"$(INTDIR)\pgtclCmds.obj" \
"$(INTDIR)\pgtclId.obj"
"$(OUTDIR)\libpgtcl.dll" : "$(OUTDIR)" $(DEF_FILE) $(LINK32_OBJS)
$(LINK32) @<<
$(LINK32_FLAGS) $(LINK32_OBJS)
<<
!ENDIF
.c{$(INTDIR)}.obj::
$(CPP) @<<
$(CPP_PROJ) $<
<<
.cpp{$(INTDIR)}.obj::
$(CPP) @<<
$(CPP_PROJ) $<
<<
.cxx{$(INTDIR)}.obj::
$(CPP) @<<
$(CPP_PROJ) $<
<<
.c{$(INTDIR)}.sbr::
$(CPP) @<<
$(CPP_PROJ) $<
<<
.cpp{$(INTDIR)}.sbr::
$(CPP) @<<
$(CPP_PROJ) $<
<<
.cxx{$(INTDIR)}.sbr::
$(CPP) @<<
$(CPP_PROJ) $<
<<
!IF "$(CFG)" == "libpgtcl - Win32 Release" || "$(CFG)" == "libpgtcl - Win32 Debug"
SOURCE=pgtcl.c
"$(INTDIR)\pgtcl.obj" "$(INTDIR)\pgtcl.sbr" : $(SOURCE) "$(INTDIR)"
$(CPP) $(CPP_PROJ) $(SOURCE)
SOURCE=pgtclCmds.c
"$(INTDIR)\pgtclCmds.obj" "$(INTDIR)\pgtclCmds.sbr" : $(SOURCE) "$(INTDIR)"
$(CPP) $(CPP_PROJ) $(SOURCE)
SOURCE=pgtclId.c
"$(INTDIR)\pgtclId.obj" "$(INTDIR)\pgtclId.sbr" : $(SOURCE) "$(INTDIR)"
$(CPP) $(CPP_PROJ) $(SOURCE)
!ENDIF
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment