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;
+}