Posted to tcl by ro at Sun Sep 20 23:43:51 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 BerryfotoSetPixelsCmd(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_set_pixels", BerryfotoSetPixelsCmd,
  27. (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
  28.  
  29. return TCL_OK;
  30. }
  31.  
  32.  
  33. int BerryfotoSetPixelsCmd(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.  
  43. Tcl_Obj *sublistObj = NULL;
  44. Tcl_Obj *sublistElemObj = NULL;
  45. int red, green, blue;
  46.  
  47.  
  48. if (objc != 3) {
  49. Tcl_WrongNumArgs(interp, 1, objv, "photo_name pixel_list");
  50. return TCL_ERROR;
  51. }
  52.  
  53. photo = Tk_FindPhoto(interp, Tcl_GetString(objv[1]));
  54. if (photo == NULL) {
  55. Tcl_SetResult(interp, "not an image name", TCL_STATIC);
  56. return TCL_ERROR;
  57. }
  58.  
  59. Tk_PhotoGetImage(photo, &block);
  60.  
  61. listObj = objv[2];
  62. if (Tcl_ListObjLength(interp, listObj, &length) != TCL_OK) {
  63. return TCL_ERROR;
  64. }
  65.  
  66.  
  67. /* make sure the length of the pixel list is the same as the block size */
  68.  
  69. if ((block.width * block.height) != length) {
  70. Tcl_SetResult(interp, "incorrect pixel list length", TCL_STATIC);
  71. return TCL_ERROR;
  72. }
  73.  
  74. for (i=0; i<length; i++) {
  75.  
  76. /* get the sublist r,g,b triplet */
  77. if (Tcl_ListObjIndex(interp, listObj, i, &sublistObj) != TCL_OK) {
  78. return TCL_ERROR;
  79. }
  80.  
  81.  
  82. /* now get the elements out of the r,g,b sublist */
  83.  
  84. if (Tcl_ListObjIndex(interp, sublistObj, 0, &sublistElemObj) != TCL_OK) {
  85. return TCL_ERROR;
  86. }
  87. if (Tcl_GetIntFromObj(interp, sublistElemObj, &red) != TCL_OK) {
  88. return TCL_ERROR;
  89. }
  90.  
  91. if (Tcl_ListObjIndex(interp, sublistObj, 1, &sublistElemObj) != TCL_OK) {
  92. return TCL_ERROR;
  93. }
  94. if (Tcl_GetIntFromObj(interp, sublistElemObj, &green) != TCL_OK) {
  95. return TCL_ERROR;
  96. }
  97.  
  98. if (Tcl_ListObjIndex(interp, sublistObj, 2, &sublistElemObj) != TCL_OK) {
  99. return TCL_ERROR;
  100. }
  101. if (Tcl_GetIntFromObj(interp, sublistElemObj, &blue) != TCL_OK) {
  102. return TCL_ERROR;
  103. }
  104.  
  105.  
  106. block.pixelPtr[i * 4 + 0] = red;
  107. block.pixelPtr[i * 4 + 1] = green;
  108. block.pixelPtr[i * 4 + 2] = blue;
  109. block.pixelPtr[i * 4 + 3] = 255; /* alpha, 255 is opaque */
  110.  
  111. }
  112.  
  113. Tk_PhotoPutBlock(interp, photo, &block, 0, 0, block.width, block.height, TK_PHOTO_COMPOSITE_SET);
  114.  
  115.  
  116. return TCL_OK;
  117. }
  118.  
  119.