Posted to tcl by miguel at Mon Jan 23 22:39:19 GMT 2012view raw

  1. #include "tcl.h"
  2. #include <stdio.h>
  3. #include <stdlib.h>
  4. #include <windows.h>
  5.  
  6. bool APIENTRY DllMain (void * hInst, int reason, void * reserved)
  7. {
  8. switch (reason)
  9. {
  10. case DLL_PROCESS_ATTACH:
  11. break;
  12.  
  13. case DLL_PROCESS_DETACH:
  14. break;
  15.  
  16. case DLL_THREAD_ATTACH:
  17. break;
  18.  
  19. case DLL_THREAD_DETACH:
  20. break;
  21. }
  22. return TRUE;
  23. }
  24.  
  25. void _StdOutObj(const char * pref, Tcl_Obj * objPtr) {
  26. Tcl_Channel ch = Tcl_GetStdChannel(TCL_STDOUT);
  27. Tcl_WriteChars(ch, pref, -1);
  28. int len;
  29. Tcl_WriteChars(ch, Tcl_GetStringFromObj(objPtr, &len), len);
  30. Tcl_WriteChars(ch, "\n", 1);
  31. Tcl_Flush(ch);
  32. };
  33.  
  34. void __cdecl testDP_FreeIntRep(Tcl_Obj * objPtr) {
  35. Tcl_Interp * interp = (Tcl_Interp *)objPtr->internalRep.twoPtrValue.ptr1;
  36. objPtr = (Tcl_Obj *)objPtr->internalRep.twoPtrValue.ptr2;
  37.  
  38. // save interp state/result :
  39. Tcl_InterpState state = Tcl_SaveInterpState(interp, 0);
  40.  
  41. // this call runs in "OnDeletePending" mode ...
  42. int res = Tcl_EvalObjEx(interp, objPtr, 0);
  43.  
  44. // output result of call :
  45. _StdOutObj((res == TCL_OK ? "OK: " : "ERROR: "), Tcl_GetObjResult(interp));
  46.  
  47. // restore interp :
  48. Tcl_RestoreInterpState(interp, state);
  49.  
  50. Tcl_DecrRefCount(objPtr);
  51. };
  52.  
  53. Tcl_ObjType testDP_Type =
  54. {
  55. "testDP",
  56. testDP_FreeIntRep,
  57. NULL,
  58. NULL,
  59. NULL
  60. };
  61.  
  62. int __cdecl testDP_Cmd(void *, Tcl_Interp * interp, int argc, Tcl_Obj * const argv[])
  63. {
  64. if (argc != 2) {
  65. Tcl_SetResult(interp, "usage: testDP <body-to-test-with-deletepending>", TCL_STATIC);
  66. };
  67. Tcl_Obj * newObj = Tcl_NewObj();
  68. newObj->typePtr = &testDP_Type;
  69. newObj->internalRep.twoPtrValue.ptr1 = interp;
  70. newObj->internalRep.twoPtrValue.ptr2 = argv[1];
  71. Tcl_IncrRefCount(argv[1]);
  72. Tcl_SetObjResult(interp, newObj);
  73. return TCL_OK;
  74. }
  75.  
  76. extern "C" int __declspec(dllexport) Test_Init(Tcl_Interp * interp)
  77. {
  78. if (
  79. #ifdef USE_TCL_STUBS
  80. Tcl_InitStubs(interp, "8.5", 0)
  81. #else
  82. Tcl_PkgRequire(interp, "Tcl", "8.5", 0)
  83. #endif
  84. == NULL) {
  85. return TCL_ERROR;
  86. };
  87. Tcl_CreateObjCommand(interp, "testDP", testDP_Cmd, NULL, NULL);
  88. return TCL_OK;
  89. }
  90.  
  91. /*
  92. -------------------------- TCL - code examples to test it -------------------
  93. % load test
  94.  
  95. % set x [testDP {file normalize {/a/b/c/d}}]
  96. % unset x
  97. OK: D:/a/b/c/d
  98.  
  99. % set x [testDP {file normalize {/a/b/../c/d}}]
  100. % unset x
  101. Tcl_SetObjLength called with shared object
  102.  
  103. This application has requested the Runtime to terminate it in an unusual way.
  104. Please contact the application's support team for more information.
  105. ------------------------------------------------------------------------------
  106. */
  107.