Posted to tcl by ro at Fri Sep 18 17:20:33 GMT 2009view raw
- #define USE_TCL_STUBS
- #define USE_TK_STUBS
- #include <tcl.h>
- #include <tk.h>
- #include <windows.h>
- #undef TCL_STORAGE_CLASS
- #define TCL_STORAGE_CLASS DLLEXPORT
- int BerryfotoNewCmd(ClientData clientdata, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
- EXTERN int
- Berryfoto_Init(Tcl_Interp *interp)
- {
- if (Tcl_InitStubs(interp, "8.1", 0) == NULL) {
- return TCL_ERROR;
- }
- if (Tk_InitStubs(interp, "8.1", 0) == NULL) {
- return TCL_ERROR;
- }
- Tcl_CreateObjCommand(interp, "berryfoto_new", BerryfotoNewCmd,
- (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
- return TCL_OK;
- }
- int BerryfotoNewCmd(ClientData clientdata, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[])
- {
- Tk_PhotoHandle photo;
- Tk_PhotoImageBlock block;
- Tcl_Obj *listObj = NULL;
- int length, i;
- Tcl_Obj *elemObj = NULL;
- /* int pixel; */
- Tcl_Obj *sublistObj = NULL;
- Tcl_Obj *sublistElemObj = NULL;
- int red, green, blue;
- Tcl_Obj *resultObj = NULL;
- if (objc != 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "photo_name pixel_list");
- return TCL_ERROR;
- }
- photo = Tk_FindPhoto(interp, Tcl_GetString(objv[1]));
- if (photo == NULL) {
- Tcl_SetResult(interp, "not an image name", TCL_STATIC);
- return TCL_ERROR;
- }
- Tk_PhotoGetImage(photo, &block);
- listObj = objv[2];
- if (Tcl_ListObjLength(interp, listObj, &length) != TCL_OK) {
- Tcl_SetResult(interp, "could not get length of list", TCL_STATIC);
- return TCL_ERROR;
- }
- /* make sure the length of the pixel list is the same as the block size */
- if ((block.width * block.height) != length) {
- Tcl_SetResult(interp, "incorrect pixel list length", TCL_STATIC);
- return TCL_ERROR;
- }
- for (i=0; i<length; i++) {
- if (Tcl_ListObjIndex(interp, listObj, i, &elemObj) != TCL_OK) {
- Tcl_SetResult(interp, "could not iterate over element", TCL_STATIC);
- return TCL_ERROR;
- }
- sublistObj = elemObj;
- Tcl_ListObjIndex(interp, sublistObj, 0, &sublistElemObj);
- if (Tcl_GetIntFromObj(interp, sublistElemObj, &red) != TCL_OK) {
- Tcl_SetResult(interp, "could not get integer from element", TCL_STATIC);
- return TCL_ERROR;
- }
- Tcl_ListObjIndex(interp, sublistObj, 1, &sublistElemObj);
- if (Tcl_GetIntFromObj(interp, sublistElemObj, &green) != TCL_OK) {
- Tcl_SetResult(interp, "could not get integer from element", TCL_STATIC);
- return TCL_ERROR;
- }
- Tcl_ListObjIndex(interp, sublistObj, 2, &sublistElemObj);
- if (Tcl_GetIntFromObj(interp, sublistElemObj, &blue) != TCL_OK) {
- Tcl_SetResult(interp, "could not get integer from element", TCL_STATIC);
- return TCL_ERROR;
- }
- block.pixelPtr[i * 4 + 0] = red;
- block.pixelPtr[i * 4 + 1] = green;
- block.pixelPtr[i * 4 + 2] = blue;
- block.pixelPtr[i * 4 + 3] = 255;
- }
- Tk_PhotoPutBlock(interp, photo, &block, 0, 0, block.width, block.height, TK_PHOTO_COMPOSITE_SET);
- resultObj = Tcl_GetObjResult(interp);
- Tcl_SetIntObj(resultObj, 9009);
- return TCL_OK;
- }