Attachment "test.cpp" to
ticket [3475569fff]
added by
nijtmans
2012-01-24 05:28:24.
Also attachment "test.cpp" to
ticket [3475569fff]
added by
sebres
2012-01-23 17:47:26.
#include "tcl.h"
#include <stdio.h>
#include <stdlib.h>
#include <windows.h>
bool APIENTRY DllMain (void * hInst, int reason, void * reserved)
{
switch (reason)
{
case DLL_PROCESS_ATTACH:
break;
case DLL_PROCESS_DETACH:
break;
case DLL_THREAD_ATTACH:
break;
case DLL_THREAD_DETACH:
break;
}
return TRUE;
}
void _StdOutObj(const char * pref, Tcl_Obj * objPtr) {
Tcl_Channel ch = Tcl_GetStdChannel(TCL_STDOUT);
Tcl_WriteChars(ch, pref, -1);
int len;
Tcl_WriteChars(ch, Tcl_GetStringFromObj(objPtr, &len), len);
Tcl_WriteChars(ch, "\n", 1);
Tcl_Flush(ch);
};
void __cdecl testDP_FreeIntRep(Tcl_Obj * objPtr) {
Tcl_Interp * interp = (Tcl_Interp *)objPtr->internalRep.twoPtrValue.ptr1;
objPtr = (Tcl_Obj *)objPtr->internalRep.twoPtrValue.ptr2;
// save interp state/result :
Tcl_InterpState state = Tcl_SaveInterpState(interp, 0);
// this call runs in "OnDeletePending" mode ...
int res = Tcl_EvalObjEx(interp, objPtr, 0);
// output result of call :
_StdOutObj((res == TCL_OK ? "OK: " : "ERROR: "), Tcl_GetObjResult(interp));
// restore interp :
Tcl_RestoreInterpState(interp, state);
Tcl_DecrRefCount(objPtr);
};
Tcl_ObjType testDP_Type =
{
"testDP",
testDP_FreeIntRep,
NULL,
NULL,
NULL
};
int __cdecl testDP_Cmd(void *, Tcl_Interp * interp, int argc, Tcl_Obj * const argv[])
{
if (argc != 2) {
Tcl_SetResult(interp, "usage: testDP <body-to-test-with-deletepending>", TCL_STATIC);
};
Tcl_Obj * newObj = Tcl_NewObj();
newObj->typePtr = &testDP_Type;
newObj->internalRep.twoPtrValue.ptr1 = interp;
newObj->internalRep.twoPtrValue.ptr2 = argv[1];
Tcl_IncrRefCount(argv[1]);
Tcl_SetObjResult(interp, newObj);
return TCL_OK;
}
extern "C" int __declspec(dllexport) Test_Init(Tcl_Interp * interp)
{
if (
#ifdef USE_TCL_STUBS
Tcl_InitStubs(interp, "8.5", 0)
#else
Tcl_PkgRequire(interp, "Tcl", "8.5", 0)
#endif
== NULL) {
return TCL_ERROR;
};
Tcl_CreateObjCommand(interp, "testDP", testDP_Cmd, NULL, NULL);
return TCL_OK;
}
/*
-------------------------- TCL - code examples to test it -------------------
% load test
% set x [testDP {file normalize {/a/b/c/d}}]
% unset x
OK: D:/a/b/c/d
% set x [testDP {file normalize {/a/b/../c/d}}]
% unset x
Tcl_SetObjLength called with shared object
This application has requested the Runtime to terminate it in an unusual way.
Please contact the application's support team for more information.
------------------------------------------------------------------------------
*/