Posted to tcl by KFF at Tue Apr 12 19:02:16 GMT 2016view raw

  1. #include <tcl.h>
  2. #include <tk.h>
  3. #include <windows.h>
  4. #include <shellapi.h>
  5. #include <stdio.h>
  6.  
  7. static int GetIcon_Cmd(ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj * CONST objv[]) {
  8. SHFILEINFO shfi;
  9. ICONINFO iconInfo ;
  10. BITMAP bmp;
  11. long imageSize ;
  12. char * bitBuffer , * byteBuffer ;
  13. int i, index;
  14. int result, hasAlpha;
  15. const char * image_name;
  16. Tk_PhotoHandle photo;
  17. Tk_PhotoImageBlock block;
  18. const char * file_name;
  19. Tcl_DString ds;
  20. HDC hdc;
  21. int bitSize;
  22. unsigned int uFlags;
  23. Tcl_Obj *pathPtr;
  24. int bit;
  25. CONST TCHAR *native;
  26.  
  27. static CONST char *options[] = {"-large", "-open", "-selected", NULL};
  28. enum IOption {ILARGE, IOPEN, ISELECTED};
  29.  
  30. if (objc < 2) {
  31. Tcl_WrongNumArgs(interp, 1, objv, "?options? fileName");
  32. return TCL_ERROR;
  33. }
  34.  
  35. /*
  36. SHGFI_ICON == SHGFI_LARGEICON so large is the default, select small instead
  37. then remove the flag if -large is specified
  38. */
  39.  
  40. uFlags = SHGFI_ICON | SHGFI_SMALLICON;
  41.  
  42. for (i=1 ; i < objc-1 ; i++) {
  43. result = Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, (int *) &index);
  44. if (result != TCL_OK) {
  45. return result;
  46. }
  47. switch (index) {
  48. case ILARGE:
  49. /* setting LARGE is equivalent to unsetting SMALL */
  50. uFlags ^= SHGFI_SMALLICON;
  51. break;
  52. case IOPEN:
  53. uFlags |= SHGFI_OPENICON;
  54. break;
  55. case ISELECTED:
  56. uFlags |= SHGFI_SELECTED;
  57. break;
  58. default:
  59. Tcl_Panic("option lookup failed");
  60. }
  61. }
  62.  
  63. /* Normalize the filename */
  64. //norm = Tcl_FSGetNormalizedPath(interp, objv[objc]);
  65. //Tcl_UtfToExternalDString(NULL, Tcl_GetString(norm), -1, &ds);
  66.  
  67. file_name = Tcl_GetString (objv[objc-1]);
  68.  
  69. //file_name = Tcl_DuplicateObj(objv[1]);
  70. //Tcl_IncrRefCount(file_name);
  71. //if (Tcl_FSConvertToPathType(interp, file_name) != TCL_OK ) {
  72. // Tcl_DecrRefCount(file_name);
  73. // return TCL_ERROR;
  74. //}
  75. //if (Tcl_FSGetNormalizedPath(interp, file_name) == NULL) {
  76. // Tcl_DecrRefCount(file_name);
  77. // return TCL_ERROR;
  78. //}
  79.  
  80. native = (CONST TCHAR*) Tcl_FSGetNativePath(file_name);
  81. native = Tcl_WinUtfToTChar(native, -1, &ds);
  82. //native = Tcl_WinUtfToTChar(dirName, -1, &ds);
  83.  
  84. file_name = Tcl_TranslateFileName(interp, native, &ds);
  85. if (file_name == NULL) {
  86. return TCL_ERROR;
  87. }
  88.  
  89. result = SHGetFileInfo(
  90. Tcl_DStringValue(&ds),
  91. 0,
  92. &shfi,
  93. sizeof(SHFILEINFO),
  94. uFlags
  95. );
  96. Tcl_DStringFree(&ds);
  97.  
  98. if (result == 0) {
  99. char msg[255];
  100. int l;
  101. Tcl_SetResult(interp, "failed to load icon: ", NULL);
  102. FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_IGNORE_INSERTS, 0, GetLastError(), 0, msg, 255, 0);
  103.  
  104. /* lose the newline */
  105. l = 0;
  106. while (msg[l]!='\r' && msg[l]!='\n' && msg[l]!='\0') {
  107. l++;
  108. }
  109. msg[l]='\0';
  110. Tcl_AppendResult(interp, msg, NULL);
  111. return TCL_ERROR;
  112. }
  113.  
  114. GetIconInfo(shfi.hIcon, &iconInfo);
  115.  
  116. result = GetObject(
  117. iconInfo.hbmMask,
  118. sizeof(BITMAP),
  119. (void *)&bmp
  120. );
  121.  
  122. bitSize = bmp.bmWidth * bmp.bmHeight * bmp.bmBitsPixel / 8;
  123.  
  124. bitBuffer = ckalloc(bitSize);
  125. GetBitmapBits(iconInfo.hbmMask,bitSize,bitBuffer);
  126.  
  127. result = GetObject(
  128. iconInfo.hbmColor,
  129. sizeof(BITMAP),
  130. (void *)&bmp
  131. );
  132.  
  133. imageSize = bmp.bmWidth * bmp.bmHeight * bmp.bmBitsPixel / 8;
  134. byteBuffer = ckalloc(imageSize);
  135. GetBitmapBits(iconInfo.hbmColor,imageSize,byteBuffer);
  136.  
  137. /* Do some mask and Alpha channel voodoo, because not all Icons define an alpha channel
  138. and MS has decided to make completely transparent the default in that case, AAARGGH
  139. Might be some bit masking I am missing here though.
  140. */
  141.  
  142. hasAlpha = 0;
  143. for (i = 0 ; i < imageSize ; i+=4) {
  144. if (byteBuffer[i+offsetof(RGBQUAD,rgbReserved)]!=0) {
  145. hasAlpha = 1;
  146. break;
  147. }
  148. }
  149.  
  150. #define BIT_SET(x,y) (((x) >> (8-(y)) ) & 1 )
  151.  
  152. for (i=0;i<bitSize;i++) {
  153. if (hasAlpha) break;
  154. // if (i%2==0) {fprintf(stderr,"\n");}
  155. bit = 0;
  156. for (bit=0; bit < 8 ; bit++) {
  157. if (BIT_SET(bitBuffer[i],bit)) {
  158. // fprintf(stderr,"0");
  159. byteBuffer[(i*8+bit)*4+3] = 0;
  160. } else {
  161. // fprintf(stderr,"1");
  162. byteBuffer[(i*8+bit)*4+3] = 255;
  163. }
  164. }
  165. }
  166.  
  167. /* setup the Tk block structure */
  168. block.pixelPtr = byteBuffer;
  169. block.width = bmp.bmWidth;
  170. block.height = bmp.bmHeight;
  171. block.pitch = bmp.bmWidthBytes;
  172. block.pixelSize = bmp.bmBitsPixel/8;
  173. block.offset[0] = offsetof(RGBQUAD,rgbRed);
  174. block.offset[1] = offsetof(RGBQUAD,rgbGreen);
  175. block.offset[2] = offsetof(RGBQUAD,rgbBlue);
  176. block.offset[3] = offsetof(RGBQUAD,rgbReserved);
  177.  
  178. /* Create the image */
  179. result = Tcl_Eval(interp,"image create photo");
  180. if (result != TCL_OK) {
  181. return TCL_ERROR;
  182. }
  183. image_name = Tcl_GetStringResult(interp);
  184. photo = Tk_FindPhoto(interp, image_name);
  185.  
  186. result = Tk_PhotoPutBlock( interp,photo, &block ,0,0,block.width, block.height,TK_PHOTO_COMPOSITE_SET);
  187.  
  188. if (result != TCL_OK) {
  189. return TCL_ERROR;
  190. }
  191.  
  192. //cleanup
  193. ckfree(bitBuffer);
  194. ckfree(byteBuffer);
  195.  
  196. DeleteObject(iconInfo.hbmMask);
  197. DeleteObject(iconInfo.hbmColor);
  198. DestroyIcon(shfi.hIcon);
  199.  
  200. Tcl_AppendResult(interp, image_name, NULL);
  201. return TCL_OK;
  202. }
  203.  
  204. int DLLEXPORT
  205. Shellicon_Init(Tcl_Interp *interp)
  206. {
  207. if (Tcl_InitStubs(interp, "8.4", 0) == 0L) {
  208. return TCL_ERROR;
  209. }
  210. if (Tk_InitStubs(interp, "8.4", 0) == 0L) {
  211. return TCL_ERROR;
  212. }
  213. Tcl_CreateObjCommand(interp, "shellicon::get", GetIcon_Cmd, NULL, NULL);
  214. Tcl_PkgProvide(interp, "shellicon", "0.1");
  215. return TCL_OK;
  216. }
  217.