Posted to tcl by miguel at Mon Jan 23 22:39:19 GMT 2012view raw
- #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.
- ------------------------------------------------------------------------------
- */