test.cpp from 3475569

#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.
------------------------------------------------------------------------------
*/