/*
 * pkgooa.c --
 *
 *	This file contains a simple Tcl package "pkgooa" that is intended for
 *	testing the Tcl dynamic loading facilities.
 *
 * Copyright © 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,
};

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