ag/cpython-source-deps
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Import Tcl-core 8.6.6 (as of svn r86089)

Browse Source
This commit is contained in:
Zachary Ware
2017-05-22 16:09:35 -05:00
parent d239d63057
commit 261a0e7c44
1835 changed files with 812202 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

110
unix/dltest/Makefile.in Normal file
View File

@@ -0,0 +1,110 @@
# This Makefile is used to create several test cases for Tcl's load
# command. It also illustrates how to take advantage of configuration
# exported by Tcl to set up Makefiles for shared libraries.
CC = @CC@
LIBS = @TCL_BUILD_STUB_LIB_SPEC@ @TCL_LIBS@
AC_FLAGS = @DEFS@
SHLIB_LD = @SHLIB_LD@
SHLIB_CFLAGS = @SHLIB_CFLAGS@
SHLIB_LD_LIBS = @SHLIB_LD_LIBS@
SHLIB_SUFFIX = @SHLIB_SUFFIX@
DLTEST_LD = @DLTEST_LD@
DLTEST_SUFFIX = @DLTEST_SUFFIX@
SRC_DIR = @TCL_SRC_DIR@/unix/dltest
BUILD_DIR = @builddir@
TCL_VERSION= @TCL_VERSION@
CFLAGS_DEBUG = @CFLAGS_DEBUG@
CFLAGS_OPTIMIZE = @CFLAGS_OPTIMIZE@
CFLAGS = @CFLAGS_DEFAULT@ @CFLAGS@
LDFLAGS_DEBUG = @LDFLAGS_DEBUG@
LDFLAGS_OPTIMIZE = @LDFLAGS_OPTIMIZE@
LDFLAGS = @LDFLAGS_DEFAULT@ @LDFLAGS@
CC_SWITCHES = $(CFLAGS) -I${SRC_DIR}/../../generic -DTCL_MEM_DEBUG \
${SHLIB_CFLAGS} -DUSE_TCL_STUBS ${AC_FLAGS}
all: pkga${SHLIB_SUFFIX} pkgb${SHLIB_SUFFIX} pkgc${SHLIB_SUFFIX} pkgd${SHLIB_SUFFIX} pkge${SHLIB_SUFFIX} pkgua${SHLIB_SUFFIX} pkgooa${SHLIB_SUFFIX}
@if test -n "$(DLTEST_SUFFIX)"; then $(MAKE) dltest_suffix; fi
@touch ../dltest.marker
dltest_suffix: pkga${DLTEST_SUFFIX} pkgb${DLTEST_SUFFIX} pkgc${DLTEST_SUFFIX} pkgd${DLTEST_SUFFIX} pkge${DLTEST_SUFFIX} pkgua${DLTEST_SUFFIX} pkgooa${DLTEST_SUFFIX}
@touch ../dltest.marker
pkga.o: $(SRC_DIR)/pkga.c
$(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkga.c
pkgb.o: $(SRC_DIR)/pkgb.c
$(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgb.c
pkgc.o: $(SRC_DIR)/pkgc.c
$(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgc.c
pkgd.o: $(SRC_DIR)/pkgd.c
$(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgd.c
pkge.o: $(SRC_DIR)/pkge.c
$(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkge.c
pkgua.o: $(SRC_DIR)/pkgua.c
$(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgua.c
pkgooa.o: $(SRC_DIR)/pkgooa.c
$(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgooa.c
pkga${SHLIB_SUFFIX}: pkga.o
${SHLIB_LD} -o pkga${SHLIB_SUFFIX} pkga.o ${SHLIB_LD_LIBS}
pkgb${SHLIB_SUFFIX}: pkgb.o
${SHLIB_LD} -o pkgb${SHLIB_SUFFIX} pkgb.o ${SHLIB_LD_LIBS}
pkgc${SHLIB_SUFFIX}: pkgc.o
${SHLIB_LD} -o pkgc${SHLIB_SUFFIX} pkgc.o ${SHLIB_LD_LIBS}
pkgd${SHLIB_SUFFIX}: pkgd.o
${SHLIB_LD} -o pkgd${SHLIB_SUFFIX} pkgd.o ${SHLIB_LD_LIBS}
pkge${SHLIB_SUFFIX}: pkge.o
${SHLIB_LD} -o pkge${SHLIB_SUFFIX} pkge.o ${SHLIB_LD_LIBS}
pkgua${SHLIB_SUFFIX}: pkgua.o
${SHLIB_LD} -o pkgua${SHLIB_SUFFIX} pkgua.o ${SHLIB_LD_LIBS}
pkgooa${SHLIB_SUFFIX}: pkgooa.o
${SHLIB_LD} -o pkgooa${SHLIB_SUFFIX} pkgooa.o ${SHLIB_LD_LIBS}
pkga${DLTEST_SUFFIX}: pkga.o
${DLTEST_LD} -o pkga${DLTEST_SUFFIX} pkga.o ${SHLIB_LD_LIBS}
pkgb${DLTEST_SUFFIX}: pkgb.o
${DLTEST_LD} -o pkgb${DLTEST_SUFFIX} pkgb.o ${SHLIB_LD_LIBS}
pkgc${DLTEST_SUFFIX}: pkgc.o
${DLTEST_LD} -o pkgc${DLTEST_SUFFIX} pkgc.o ${SHLIB_LD_LIBS}
pkgd${DLTEST_SUFFIX}: pkgd.o
${DLTEST_LD} -o pkgd${DLTEST_SUFFIX} pkgd.o ${SHLIB_LD_LIBS}
pkge${DLTEST_SUFFIX}: pkge.o
${DLTEST_LD} -o pkge${DLTEST_SUFFIX} pkge.o ${SHLIB_LD_LIBS}
pkgua${DLTEST_SUFFIX}: pkgua.o
${DLTEST_LD} -o pkgua${DLTEST_SUFFIX} pkgua.o ${SHLIB_LD_LIBS}
pkgooa${DLTEST_SUFFIX}: pkgooa.o
${DLTEST_LD} -o pkgooa${DLTEST_SUFFIX} pkgooa.o ${SHLIB_LD_LIBS}
clean:
rm -f *.o lib.exp ../dltest.marker
@if test "$(SHLIB_SUFFIX)" != ""; then \
echo "rm -f *${SHLIB_SUFFIX}" ; \
rm -f *${SHLIB_SUFFIX} ; \
fi
@if test "$(DLTEST_SUFFIX)" != ""; then \
echo "rm -f *${DLTEST_SUFFIX}" ; \
rm -f *${DLTEST_SUFFIX} ; \
fi
distclean: clean
rm -f Makefile

4
unix/dltest/README Normal file
View File

@@ -0,0 +1,4 @@
This directory contains several files for testing Tcl's dynamic
loading/unloading capabilities. If shared libraries are supported
then the build system in the parent directory will create
the shared libs and load them into the tcltest executable.

145
unix/dltest/pkga.c Normal file
View File

@@ -0,0 +1,145 @@
/*
* pkga.c --
*
* This file contains a simple Tcl package "pkga" that is intended for
* testing the Tcl dynamic loading facilities.
*
* Copyright (c) 1995 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#undef STATIC_BUILD
#include "tcl.h"
/*
* TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the
* Pkga_Init declaration is in the source file itself, which is only
* accessed when we are building a library.
*/
#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLEXPORT
/*
* Prototypes for procedures defined later in this file:
*/
static int Pkga_EqObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
static int Pkga_QuoteObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
/*
*----------------------------------------------------------------------
*
* Pkga_EqObjCmd --
*
* This procedure is invoked to process the "pkga_eq" Tcl command. It
* expects two arguments and returns 1 if they are the same, 0 if they
* are different.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
Pkga_EqObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int result;
const char *str1, *str2;
int len1, len2;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "string1 string2");
return TCL_ERROR;
}
str1 = Tcl_GetStringFromObj(objv[1], &len1);
str2 = Tcl_GetStringFromObj(objv[2], &len2);
if (len1 == len2) {
result = (Tcl_UtfNcmp(str1, str2, len1) == 0);
} else {
result = 0;
}
Tcl_SetObjResult(interp, Tcl_NewIntObj(result));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Pkga_QuoteObjCmd --
*
* This procedure is invoked to process the "pkga_quote" Tcl command. It
* expects one argument, which it returns as result.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
Pkga_QuoteObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument strings. */
{
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "value");
return TCL_ERROR;
}
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Pkga_Init --
*
* This is a package initialization procedure, which is called by Tcl
* when this package is to be added to an interpreter.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
EXTERN int
Pkga_Init(
Tcl_Interp *interp) /* Interpreter in which the package is to be
* made available. */
{
int code;
if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) {
return TCL_ERROR;
}
code = Tcl_PkgProvide(interp, "Pkga", "1.0");
if (code != TCL_OK) {
return code;
}
Tcl_CreateObjCommand(interp, "pkga_eq", Pkga_EqObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "pkga_quote", Pkga_QuoteObjCmd, NULL,
NULL);
return TCL_OK;
}

190
unix/dltest/pkgb.c Normal file
View File

@@ -0,0 +1,190 @@
/*
* pkgb.c --
*
* This file contains a simple Tcl package "pkgb" that is intended for
* testing the Tcl dynamic loading facilities. It can be used in both
* safe and unsafe interpreters.
*
* Copyright (c) 1995 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#undef STATIC_BUILD
#include "tcl.h"
/*
* Prototypes for procedures defined later in this file:
*/
static int Pkgb_SubObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
static int Pkgb_UnsafeObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
static int Pkgb_DemoObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
/*
*----------------------------------------------------------------------
*
* Pkgb_SubObjCmd --
*
* This procedure is invoked to process the "pkgb_sub" Tcl command. It
* expects two arguments and returns their difference.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
#ifndef Tcl_GetErrorLine
# define Tcl_GetErrorLine(interp) ((interp)->errorLine)
#endif
static int
Pkgb_SubObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int first, second;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "num num");
return TCL_ERROR;
}
if ((Tcl_GetIntFromObj(interp, objv[1], &first) != TCL_OK)
|| (Tcl_GetIntFromObj(interp, objv[2], &second) != TCL_OK)) {
char buf[TCL_INTEGER_SPACE];
sprintf(buf, "%d", Tcl_GetErrorLine(interp));
Tcl_AppendResult(interp, " in line: ", buf, NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewIntObj(first - second));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Pkgb_UnsafeObjCmd --
*
* This procedure is invoked to process the "pkgb_unsafe" Tcl command. It
* just returns a constant string.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
Pkgb_UnsafeObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_EvalEx(interp, "list unsafe command invoked", -1, TCL_EVAL_GLOBAL);
}
static int
Pkgb_DemoObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
#if (TCL_MAJOR_VERSION > 8) || (TCL_MINOR_VERSION > 4)
Tcl_Obj *first;
if (Tcl_ListObjIndex(NULL, Tcl_GetEncodingSearchPath(), 0, &first)
== TCL_OK) {
Tcl_SetObjResult(interp, first);
}
#else
Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetDefaultEncodingDir(), -1));
#endif
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Pkgb_Init --
*
* This is a package initialization procedure, which is called by Tcl
* when this package is to be added to an interpreter.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
DLLEXPORT int
Pkgb_Init(
Tcl_Interp *interp) /* Interpreter in which the package is to be
* made available. */
{
int code;
if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
return TCL_ERROR;
}
code = Tcl_PkgProvide(interp, "Pkgb", "2.3");
if (code != TCL_OK) {
return code;
}
Tcl_CreateObjCommand(interp, "pkgb_sub", Pkgb_SubObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "pkgb_unsafe", Pkgb_UnsafeObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "pkgb_demo", Pkgb_DemoObjCmd, NULL, NULL);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Pkgb_SafeInit --
*
* This is a package initialization procedure, which is called by Tcl
* when this package is to be added to a safe interpreter.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
DLLEXPORT int
Pkgb_SafeInit(
Tcl_Interp *interp) /* Interpreter in which the package is to be
* made available. */
{
int code;
if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
return TCL_ERROR;
}
code = Tcl_PkgProvide(interp, "Pkgb", "2.3");
if (code != TCL_OK) {
return code;
}
Tcl_CreateObjCommand(interp, "pkgb_sub", Pkgb_SubObjCmd, NULL, NULL);
return TCL_OK;
}

170
unix/dltest/pkgc.c Normal file
View File

@@ -0,0 +1,170 @@
/*
* pkgc.c --
*
* This file contains a simple Tcl package "pkgc" that is intended for
* testing the Tcl dynamic loading facilities. It can be used in both
* safe and unsafe interpreters.
*
* Copyright (c) 1995 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#undef STATIC_BUILD
#include "tcl.h"
/*
* TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the
* Pkgc_Init declaration is in the source file itself, which is only
* accessed when we are building a library.
*/
#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLEXPORT
/*
* Prototypes for procedures defined later in this file:
*/
static int Pkgc_SubObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
static int Pkgc_UnsafeObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
/*
*----------------------------------------------------------------------
*
* Pkgc_SubObjCmd --
*
* This procedure is invoked to process the "pkgc_sub" Tcl command. It
* expects two arguments and returns their difference.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
Pkgc_SubObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int first, second;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "num num");
return TCL_ERROR;
}
if ((Tcl_GetIntFromObj(interp, objv[1], &first) != TCL_OK)
|| (Tcl_GetIntFromObj(interp, objv[2], &second) != TCL_OK)) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewIntObj(first - second));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Pkgc_UnsafeCmd --
*
* This procedure is invoked to process the "pkgc_unsafe" Tcl command. It
* just returns a constant string.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
Pkgc_UnsafeObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_SetObjResult(interp, Tcl_NewStringObj("unsafe command invoked", -1));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Pkgc_Init --
*
* This is a package initialization procedure, which is called by Tcl
* when this package is to be added to an interpreter.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
EXTERN int
Pkgc_Init(
Tcl_Interp *interp) /* Interpreter in which the package is to be
* made available. */
{
int code;
if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) {
return TCL_ERROR;
}
code = Tcl_PkgProvide(interp, "Pkgc", "1.7.2");
if (code != TCL_OK) {
return code;
}
Tcl_CreateObjCommand(interp, "pkgc_sub", Pkgc_SubObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "pkgc_unsafe", Pkgc_UnsafeObjCmd, NULL,
NULL);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Pkgc_SafeInit --
*
* This is a package initialization procedure, which is called by Tcl
* when this package is to be added to a safe interpreter.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
EXTERN int
Pkgc_SafeInit(
Tcl_Interp *interp) /* Interpreter in which the package is to be
* made available. */
{
int code;
if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) {
return TCL_ERROR;
}
code = Tcl_PkgProvide(interp, "Pkgc", "1.7.2");
if (code != TCL_OK) {
return code;
}
Tcl_CreateObjCommand(interp, "pkgc_sub", Pkgc_SubObjCmd, NULL, NULL);
return TCL_OK;
}

170
unix/dltest/pkgd.c Normal file
View File

@@ -0,0 +1,170 @@
/*
* pkgd.c --
*
* This file contains a simple Tcl package "pkgd" that is intended for
* testing the Tcl dynamic loading facilities. It can be used in both
* safe and unsafe interpreters.
*
* Copyright (c) 1995 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#undef STATIC_BUILD
#include "tcl.h"
/*
* TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the
* Pkgd_Init declaration is in the source file itself, which is only
* accessed when we are building a library.
*/
#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLEXPORT
/*
* Prototypes for procedures defined later in this file:
*/
static int Pkgd_SubObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
static int Pkgd_UnsafeObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
/*
*----------------------------------------------------------------------
*
* Pkgd_SubObjCmd --
*
* This procedure is invoked to process the "pkgd_sub" Tcl command. It
* expects two arguments and returns their difference.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
Pkgd_SubObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int first, second;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "num num");
return TCL_ERROR;
}
if ((Tcl_GetIntFromObj(interp, objv[1], &first) != TCL_OK)
|| (Tcl_GetIntFromObj(interp, objv[2], &second) != TCL_OK)) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewIntObj(first - second));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Pkgd_UnsafeCmd --
*
* This procedure is invoked to process the "pkgd_unsafe" Tcl command. It
* just returns a constant string.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
Pkgd_UnsafeObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_SetObjResult(interp, Tcl_NewStringObj("unsafe command invoked", -1));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Pkgd_Init --
*
* This is a package initialization procedure, which is called by Tcl
* when this package is to be added to an interpreter.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
EXTERN int
Pkgd_Init(
Tcl_Interp *interp) /* Interpreter in which the package is to be
* made available. */
{
int code;
if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) {
return TCL_ERROR;
}
code = Tcl_PkgProvide(interp, "Pkgd", "7.3");
if (code != TCL_OK) {
return code;
}
Tcl_CreateObjCommand(interp, "pkgd_sub", Pkgd_SubObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "pkgd_unsafe", Pkgd_UnsafeObjCmd, NULL,
NULL);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Pkgd_SafeInit --
*
* This is a package initialization procedure, which is called by Tcl
* when this package is to be added to a safe interpreter.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
EXTERN int
Pkgd_SafeInit(
Tcl_Interp *interp) /* Interpreter in which the package is to be
* made available. */
{
int code;
if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) {
return TCL_ERROR;
}
code = Tcl_PkgProvide(interp, "Pkgd", "7.3");
if (code != TCL_OK) {
return code;
}
Tcl_CreateObjCommand(interp, "pkgd_sub", Pkgd_SubObjCmd, NULL, NULL);
return TCL_OK;
}

54
unix/dltest/pkge.c Normal file
View File

@@ -0,0 +1,54 @@
/*
* pkge.c --
*
* This file contains a simple Tcl package "pkge" that is intended for
* testing the Tcl dynamic loading facilities. Its Init procedure returns
* an error in order to test how this is handled.
*
* Copyright (c) 1995 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#undef STATIC_BUILD
#include "tcl.h"
/*
* TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the
* Pkge_Init declaration is in the source file itself, which is only
* accessed when we are building a library.
*/
#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLEXPORT
/*
*----------------------------------------------------------------------
*
* Pkge_Init --
*
* This is a package initialization procedure, which is called by Tcl
* when this package is to be added to an interpreter.
*
* Results:
* Returns TCL_ERROR and leaves an error message in interp->result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
EXTERN int
Pkge_Init(
Tcl_Interp *interp) /* Interpreter in which the package is to be
* made available. */
{
static const char script[] = "if 44 {open non_existent}";
if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) {
return TCL_ERROR;
}
return Tcl_EvalEx(interp, script, -1, 0);
}

141
unix/dltest/pkgooa.c Normal file
View File

@@ -0,0 +1,141 @@
/*
* pkgooa.c --
*
* This file contains a simple Tcl package "pkgooa" that is intended for
* testing the Tcl dynamic loading facilities.
*
* Copyright (c) 1995 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#undef STATIC_BUILD
#include "tclOO.h"
#include <string.h>
/*
*----------------------------------------------------------------------
*
* Pkgooa_StubsOKObjCmd --
*
* This procedure is invoked to process the "pkgooa_stubsok" Tcl command.
* It gives 1 if stubs are used correctly, 0 if stubs are not OK.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
Pkgooa_StubsOKObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, "");
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewIntObj(
Tcl_CopyObjectInstance == tclOOStubsPtr->tcl_CopyObjectInstance));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Pkgooa_Init --
*
* This is a package initialization procedure, which is called by Tcl
* when this package is to be added to an interpreter.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
extern void *tclOOIntStubsPtr;
static TclOOStubs stubsCopy = {
TCL_STUB_MAGIC,
NULL,
/* It doesn't really matter what implementation of
* Tcl_CopyObjectInstance is put in the "pseudo"
* stub table, since the test-case never actually
* calls this function. All that matters is that it's
* a function with a different memory address than
* the real Tcl_CopyObjectInstance function in Tcl. */
(Tcl_Object (*) (Tcl_Interp *, Tcl_Object, const char *,
const char *t)) Pkgooa_StubsOKObjCmd
/* More entries could be here, but those are not used
* for this test-case. So, being NULL is OK. */
};
extern DLLEXPORT int
Pkgooa_Init(
Tcl_Interp *interp) /* Interpreter in which the package is to be
* made available. */
{
int code;
/* Any TclOO extension which uses stubs, calls
* both Tcl_InitStubs and Tcl_OOInitStubs() and
* does not use any Tcl 8.6 features should be
* loadable in Tcl 8.5 as well, provided the
* TclOO extension (for Tcl 8.5) is installed.
* This worked in Tcl 8.6.0, and is expected
* to keep working in all future Tcl 8.x releases.
*/
if (Tcl_InitStubs(interp, "8.5", 0) == NULL) {
return TCL_ERROR;
}
if (tclStubsPtr == NULL) {
Tcl_AppendResult(interp, "Tcl stubs are not inialized, "
"did you compile using -DUSE_TCL_STUBS? ");
return TCL_ERROR;
}
if (Tcl_OOInitStubs(interp) == NULL) {
return TCL_ERROR;
}
if (tclOOStubsPtr == NULL) {
Tcl_AppendResult(interp, "TclOO stubs are not inialized");
return TCL_ERROR;
}
if (tclOOIntStubsPtr == NULL) {
Tcl_AppendResult(interp, "TclOO internal stubs are not inialized");
return TCL_ERROR;
}
/* Test case for Bug [f51efe99a7].
*
* Let tclOOStubsPtr point to an alternate stub table
* (with only a single function, that's enough for
* this test). This way, the function "pkgooa_stubsok"
* can check whether the TclOO function calls really
* use the stub table, or only pretend to.
*
* On platforms without backlinking (Windows, Cygwin,
* AIX), this code doesn't even compile without using
* stubs, but on UNIX ELF systems, the problem is
* less visible.
*/
tclOOStubsPtr = &stubsCopy;
code = Tcl_PkgProvide(interp, "Pkgooa", "1.0");
if (code != TCL_OK) {
return code;
}
Tcl_CreateObjCommand(interp, "pkgooa_stubsok", Pkgooa_StubsOKObjCmd, NULL, NULL);
return TCL_OK;
}

341
unix/dltest/pkgua.c Normal file
View File

@@ -0,0 +1,341 @@
/*
* pkgua.c --
*
* This file contains a simple Tcl package "pkgua" that is intended for
* testing the Tcl dynamic unloading facilities.
*
* Copyright (c) 1995 Sun Microsystems, Inc.
* Copyright (c) 2004 Georgios Petasis
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#undef STATIC_BUILD
#include "tcl.h"
/*
* TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the
* Pkgua_Init declaration is in the source file itself, which is only
* accessed when we are building a library.
*/
#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLEXPORT
/*
* Prototypes for procedures defined later in this file:
*/
static int PkguaEqObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
static int PkguaQuoteObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
/*
* In the following hash table we are going to store a struct that holds all
* the command tokens created by Tcl_CreateObjCommand in an interpreter,
* indexed by the interpreter. In this way, we can find which command tokens
* we have registered in a specific interpreter, in order to unload them. We
* need to keep the various command tokens we have registered, as they are the
* only safe way to unregister our registered commands, even if they have been
* renamed.
*
* Note that this code is utterly single-threaded.
*/
static Tcl_HashTable interpTokenMap;
static int interpTokenMapInitialised = 0;
#define MAX_REGISTERED_COMMANDS 2
static void
PkguaInitTokensHashTable(void)
{
if (interpTokenMapInitialised) {
return;
}
Tcl_InitHashTable(&interpTokenMap, TCL_ONE_WORD_KEYS);
interpTokenMapInitialised = 1;
}
static void
PkguaFreeTokensHashTable(void)
{
Tcl_HashSearch search;
Tcl_HashEntry *entryPtr;
for (entryPtr = Tcl_FirstHashEntry(&interpTokenMap, &search);
entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&search)) {
Tcl_Free((char *) Tcl_GetHashValue(entryPtr));
}
interpTokenMapInitialised = 0;
}
static Tcl_Command *
PkguaInterpToTokens(
Tcl_Interp *interp)
{
int newEntry;
Tcl_Command *cmdTokens;
Tcl_HashEntry *entryPtr =
Tcl_CreateHashEntry(&interpTokenMap, (char *) interp, &newEntry);
if (newEntry) {
cmdTokens = (Tcl_Command *)
Tcl_Alloc(sizeof(Tcl_Command) * (MAX_REGISTERED_COMMANDS+1));
for (newEntry=0 ; newEntry<MAX_REGISTERED_COMMANDS+1 ; ++newEntry) {
cmdTokens[newEntry] = NULL;
}
Tcl_SetHashValue(entryPtr, cmdTokens);
} else {
cmdTokens = (Tcl_Command *) Tcl_GetHashValue(entryPtr);
}
return cmdTokens;
}
static void
PkguaDeleteTokens(
Tcl_Interp *interp)
{
Tcl_HashEntry *entryPtr =
Tcl_FindHashEntry(&interpTokenMap, (char *) interp);
if (entryPtr) {
Tcl_Free((char *) Tcl_GetHashValue(entryPtr));
Tcl_DeleteHashEntry(entryPtr);
}
}
/*
*----------------------------------------------------------------------
*
* PkguaEqObjCmd --
*
* This procedure is invoked to process the "pkgua_eq" Tcl command. It
* expects two arguments and returns 1 if they are the same, 0 if they
* are different.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
PkguaEqObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int result;
const char *str1, *str2;
int len1, len2;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "string1 string2");
return TCL_ERROR;
}
str1 = Tcl_GetStringFromObj(objv[1], &len1);
str2 = Tcl_GetStringFromObj(objv[2], &len2);
if (len1 == len2) {
result = (Tcl_UtfNcmp(str1, str2, len1) == 0);
} else {
result = 0;
}
Tcl_SetObjResult(interp, Tcl_NewIntObj(result));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* PkguaQuoteObjCmd --
*
* This procedure is invoked to process the "pkgua_quote" Tcl command. It
* expects one argument, which it returns as result.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
PkguaQuoteObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument strings. */
{
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "value");
return TCL_ERROR;
}
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Pkgua_Init --
*
* This is a package initialization procedure, which is called by Tcl
* when this package is to be added to an interpreter.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
EXTERN int
Pkgua_Init(
Tcl_Interp *interp) /* Interpreter in which the package is to be
* made available. */
{
int code, cmdIndex = 0;
Tcl_Command *cmdTokens;
if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) {
return TCL_ERROR;
}
/*
* Initialise our Hash table, where we store the registered command tokens
* for each interpreter.
*/
PkguaInitTokensHashTable();
code = Tcl_PkgProvide(interp, "Pkgua", "1.0");
if (code != TCL_OK) {
return code;
}
Tcl_SetVar(interp, "::pkgua_loaded", ".", TCL_APPEND_VALUE);
cmdTokens = PkguaInterpToTokens(interp);
cmdTokens[cmdIndex++] =
Tcl_CreateObjCommand(interp, "pkgua_eq", PkguaEqObjCmd, NULL,
NULL);
cmdTokens[cmdIndex++] =
Tcl_CreateObjCommand(interp, "pkgua_quote", PkguaQuoteObjCmd,
NULL, NULL);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Pkgua_SafeInit --
*
* This is a package initialization procedure, which is called by Tcl
* when this package is to be added to a safe interpreter.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
EXTERN int
Pkgua_SafeInit(
Tcl_Interp *interp) /* Interpreter in which the package is to be
* made available. */
{
return Pkgua_Init(interp);
}
/*
*----------------------------------------------------------------------
*
* Pkgua_Unload --
*
* This is a package unloading initialization procedure, which is called
* by Tcl when this package is to be unloaded from an interpreter.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
EXTERN int
Pkgua_Unload(
Tcl_Interp *interp, /* Interpreter from which the package is to be
* unloaded. */
int flags) /* Flags passed by the unloading mechanism */
{
int code, cmdIndex;
Tcl_Command *cmdTokens = PkguaInterpToTokens(interp);
for (cmdIndex=0 ; cmdIndex<MAX_REGISTERED_COMMANDS ; cmdIndex++) {
if (cmdTokens[cmdIndex] == NULL) {
continue;
}
code = Tcl_DeleteCommandFromToken(interp, cmdTokens[cmdIndex]);
if (code != TCL_OK) {
return code;
}
}
PkguaDeleteTokens(interp);
Tcl_SetVar(interp, "::pkgua_detached", ".", TCL_APPEND_VALUE);
if (flags == TCL_UNLOAD_DETACH_FROM_PROCESS) {
/*
* Tcl is ready to detach this library from the running application.
* We should free all the memory that is not related to any
* interpreter.
*/
PkguaFreeTokensHashTable();
Tcl_SetVar(interp, "::pkgua_unloaded", ".", TCL_APPEND_VALUE);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Pkgua_SafeUnload --
*
* This is a package unloading initialization procedure, which is called
* by Tcl when this package is to be unloaded from an interpreter.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
EXTERN int
Pkgua_SafeUnload(
Tcl_Interp *interp, /* Interpreter from which the package is to be
* unloaded. */
int flags) /* Flags passed by the unloading mechanism */
{
return Pkgua_Unload(interp, flags);
}