Posted to tcl by ro at Fri Sep 18 17:20:33 GMT 2009view raw

  1.  
  2. #define USE_TCL_STUBS
  3. #define USE_TK_STUBS
  4.  
  5. #include <tcl.h>
  6. #include <tk.h>
  7. #include <windows.h>
  8.  
  9. #undef TCL_STORAGE_CLASS
  10. #define TCL_STORAGE_CLASS DLLEXPORT
  11.  
  12. int BerryfotoNewCmd(ClientData clientdata, Tcl_Interp *interp,
  13. int objc, Tcl_Obj *const objv[]);
  14.  
  15. EXTERN int
  16. Berryfoto_Init(Tcl_Interp *interp)
  17. {
  18. if (Tcl_InitStubs(interp, "8.1", 0) == NULL) {
  19. return TCL_ERROR;
  20. }
  21.  
  22. if (Tk_InitStubs(interp, "8.1", 0) == NULL) {
  23. return TCL_ERROR;
  24. }
  25.  
  26. Tcl_CreateObjCommand(interp, "berryfoto_new", BerryfotoNewCmd,
  27. (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
  28.  
  29. return TCL_OK;
  30. }
  31.  
  32.  
  33. int BerryfotoNewCmd(ClientData clientdata, Tcl_Interp *interp,
  34. int objc, Tcl_Obj *const objv[])
  35. {
  36.  
  37. Tk_PhotoHandle photo;
  38. Tk_PhotoImageBlock block;
  39.  
  40. Tcl_Obj *listObj = NULL;
  41. int length, i;
  42. Tcl_Obj *elemObj = NULL;
  43. /* int pixel; */
  44.  
  45. Tcl_Obj *sublistObj = NULL;
  46. Tcl_Obj *sublistElemObj = NULL;
  47. int red, green, blue;
  48.  
  49. Tcl_Obj *resultObj = NULL;
  50.  
  51.  
  52.  
  53. if (objc != 3) {
  54. Tcl_WrongNumArgs(interp, 1, objv, "photo_name pixel_list");
  55. return TCL_ERROR;
  56. }
  57.  
  58. photo = Tk_FindPhoto(interp, Tcl_GetString(objv[1]));
  59. if (photo == NULL) {
  60. Tcl_SetResult(interp, "not an image name", TCL_STATIC);
  61. return TCL_ERROR;
  62. }
  63.  
  64. Tk_PhotoGetImage(photo, &block);
  65.  
  66. listObj = objv[2];
  67. if (Tcl_ListObjLength(interp, listObj, &length) != TCL_OK) {
  68. Tcl_SetResult(interp, "could not get length of list", TCL_STATIC);
  69. return TCL_ERROR;
  70. }
  71.  
  72.  
  73. /* make sure the length of the pixel list is the same as the block size */
  74.  
  75. if ((block.width * block.height) != length) {
  76. Tcl_SetResult(interp, "incorrect pixel list length", TCL_STATIC);
  77. return TCL_ERROR;
  78. }
  79.  
  80. for (i=0; i<length; i++) {
  81.  
  82. if (Tcl_ListObjIndex(interp, listObj, i, &elemObj) != TCL_OK) {
  83. Tcl_SetResult(interp, "could not iterate over element", TCL_STATIC);
  84. return TCL_ERROR;
  85. }
  86.  
  87. sublistObj = elemObj;
  88.  
  89. Tcl_ListObjIndex(interp, sublistObj, 0, &sublistElemObj);
  90. if (Tcl_GetIntFromObj(interp, sublistElemObj, &red) != TCL_OK) {
  91. Tcl_SetResult(interp, "could not get integer from element", TCL_STATIC);
  92. return TCL_ERROR;
  93. }
  94.  
  95. Tcl_ListObjIndex(interp, sublistObj, 1, &sublistElemObj);
  96. if (Tcl_GetIntFromObj(interp, sublistElemObj, &green) != TCL_OK) {
  97. Tcl_SetResult(interp, "could not get integer from element", TCL_STATIC);
  98. return TCL_ERROR;
  99. }
  100.  
  101. Tcl_ListObjIndex(interp, sublistObj, 2, &sublistElemObj);
  102. if (Tcl_GetIntFromObj(interp, sublistElemObj, &blue) != TCL_OK) {
  103. Tcl_SetResult(interp, "could not get integer from element", TCL_STATIC);
  104. return TCL_ERROR;
  105. }
  106.  
  107. block.pixelPtr[i * 4 + 0] = red;
  108. block.pixelPtr[i * 4 + 1] = green;
  109. block.pixelPtr[i * 4 + 2] = blue;
  110. block.pixelPtr[i * 4 + 3] = 255;
  111.  
  112. }
  113.  
  114. Tk_PhotoPutBlock(interp, photo, &block, 0, 0, block.width, block.height, TK_PHOTO_COMPOSITE_SET);
  115.  
  116. resultObj = Tcl_GetObjResult(interp);
  117. Tcl_SetIntObj(resultObj, 9009);
  118. return TCL_OK;
  119. }
  120.  
  121.