151 lines
4.2 KiB
C
151 lines
4.2 KiB
C
|
/*
|
|||
|
|
* 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. */
|
|||
|
|
{
|
|||
|
|
(void)dummy;
|
|||
|
|
|
|||
|
|
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))(void *)Pkgooa_StubsOKObjCmd,
|
|||
|
|
/* More entries could be here, but those are not used
|
|||
|
|
* for this test-case. So, being NULL is OK. */
|
|||
|
|
NULL, NULL, NULL, NULL, NULL, NULL, NULL,
|
|||
|
|
NULL, NULL, NULL, NULL, NULL, NULL, NULL,
|
|||
|
|
NULL, NULL, NULL, NULL, NULL, NULL, NULL,
|
|||
|
|
NULL, NULL, NULL, NULL, NULL, NULL, NULL
|
|||
|
|
#ifdef Tcl_MethodIsPrivate
|
|||
|
|
,NULL
|
|||
|
|
#endif
|
|||
|
|
};
|
|||
|
|
|
|||
|
|
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;
|
|||
|
|
}
|