summaryrefslogtreecommitdiffstats
path: root/unix/dltest/pkgooa.c
diff options
context:
space:
mode:
authorjan.nijtmans <nijtmans@users.sourceforge.net>2013-10-10 14:13:51 (GMT)
committerjan.nijtmans <nijtmans@users.sourceforge.net>2013-10-10 14:13:51 (GMT)
commit43a91548b31101b95bc2b2e29ada872bb3d9590e (patch)
tree7ddd3ac3bd4d9125f2a44ce67d4d5bb7a4540013 /unix/dltest/pkgooa.c
parentb01e1efe400bfde2a54d1fcc2e40b804b8b1b3ea (diff)
downloadtcl-43a91548b31101b95bc2b2e29ada872bb3d9590e.zip
tcl-43a91548b31101b95bc2b2e29ada872bb3d9590e.tar.gz
tcl-43a91548b31101b95bc2b2e29ada872bb3d9590e.tar.bz2
Fix for bug [f51efe99a7]: MinGW build fails on current checkin. And a new test-case which makes the problem visible on UNIX as well.
Diffstat (limited to 'unix/dltest/pkgooa.c')
-rw-r--r--unix/dltest/pkgooa.c138
1 files changed, 138 insertions, 0 deletions
diff --git a/unix/dltest/pkgooa.c b/unix/dltest/pkgooa.c
new file mode 100644
index 0000000..bdac9db
--- /dev/null
+++ b/unix/dltest/pkgooa.c
@@ -0,0 +1,138 @@
+/*
+ * 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>
+
+/*
+ * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the
+ * Pkgooa_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 Pkgooa_StubsOKObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static Tcl_Object copyObjectInstance(Tcl_Interp *interp,
+ Tcl_Object source, const char *name, const char *nameSpace)
+{
+ Tcl_Object result;
+ result = Tcl_CopyObjectInstance(interp, source, name, nameSpace);
+ if (result == NULL) {
+ Tcl_AppendResult(interp, "ERROR: copy failed.");
+ }
+ return result;
+}
+
+static TclOOStubs stubsCopy = {
+ TCL_STUB_MAGIC,
+ NULL,
+ copyObjectInstance
+ /* more entries here, but those are not
+ * needed for this test-case. */
+};
+
+EXTERN int
+Pkgooa_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;
+ }
+ if (Tcl_OOInitStubs(interp) == NULL) {
+ 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;
+}