From a87b141d105347b063df0306b8a5111d355a55a7 Mon Sep 17 00:00:00 2001
From: lecoanet
Date: Mon, 30 May 2005 15:24:37 +0000
Subject: In Perl, when doing an itemcget or itemconfigure on an image, the
 returned value is now the image object not its name. This should be far more
 useful.

---
 generic/Item.c | 31 +++++++++++++++++++++----------
 1 file changed, 21 insertions(+), 10 deletions(-)

(limited to 'generic/Item.c')

diff --git a/generic/Item.c b/generic/Item.c
index 46f2a3d..af2a1b1 100644
--- a/generic/Item.c
+++ b/generic/Item.c
@@ -119,8 +119,7 @@ Tcl_ObjType ZnAttrObjType = {
  **********************************************************************************
  */
 static void Invalidate(ZnItem item, int reason);
-static void AttributeToObj(Tcl_Interp *interp, void *record, ZnAttrConfig *desc,
-                           Tcl_Obj *result);
+static void AttributeToObj(Tcl_Interp *interp, void *record, ZnAttrConfig *desc);
 
 
 
@@ -262,22 +261,24 @@ ZnAttributesInfo(Tcl_Interp     *interp,
     entries[1] = Tcl_NewStringObj(attribute_type_strings[desc->type], -1);
     entries[2] = Tcl_NewBooleanObj(desc->read_only ? 1 : 0);
     entries[3] = Tcl_NewStringObj("", -1);
-    entries[4] = Tcl_NewStringObj("", -1);
-    AttributeToObj(interp, record, desc, entries[4]);
+    AttributeToObj(interp, record, desc);
+    entries[4] = Tcl_GetObjResult(interp);
     Tcl_SetObjResult(interp, Tcl_NewListObj(5, entries));
   }
   else {
-    l = Tcl_GetObjResult(interp);
+    l = Tcl_NewObj();
     while (desc_table->type != ZN_CONFIG_END) {
       entries[0] = Tcl_NewStringObj(desc_table->name, -1);
       entries[1] = Tcl_NewStringObj(attribute_type_strings[desc_table->type], -1);
       entries[2] = Tcl_NewBooleanObj(desc_table->read_only ? 1 : 0);
       entries[3] = Tcl_NewStringObj("", -1);
-      entries[4] = Tcl_NewStringObj("", -1);
-      AttributeToObj(interp, record, desc_table, entries[4]);
+      AttributeToObj(interp, record, desc_table);
+      entries[4] = Tcl_GetObjResult(interp);
       Tcl_ListObjAppendElement(interp, l, Tcl_NewListObj(5, entries));
+      Tcl_ResetResult(interp);
       desc_table++;
     }
+    Tcl_SetObjResult(interp, l);
   }
   
   return TCL_OK;
@@ -1058,14 +1059,14 @@ ZnConfigureAttributes(ZnWInfo           *wi,
 static void
 AttributeToObj(Tcl_Interp       *interp,
                void             *record,
-               ZnAttrConfig     *desc,
-               Tcl_Obj          *result)
+               ZnAttrConfig     *desc)
 {
   char          *valp = ((char *) record) + desc->offset;
   char          *str = "";
   Tcl_Obj       *o;
   unsigned int  i;
   char          buffer[256];
+  Tcl_Obj       *result = Tcl_GetObjResult(interp);
 
   switch (desc->type) {
   case ZN_CONFIG_GRADIENT:
@@ -1094,6 +1095,16 @@ AttributeToObj(Tcl_Interp       *interp,
     Tcl_SetBooleanObj(result, ISSET(*((unsigned short *) valp), desc->bool_bit)?1:0);
     return;
   case ZN_CONFIG_IMAGE:
+    if (*((ZnImage *) valp)) {
+      str = ZnNameOfImage(*((ZnImage *) valp));
+#if PTK
+      // Just return the perl image object, it is far more
+      // useful than the mere string name.
+      Tcl_SetObjResult(interp, LangObjectObj(interp, str));
+      return;
+#endif
+    }
+    break;
   case ZN_CONFIG_BITMAP:
     if (*((ZnImage *) valp)) {
       str = ZnNameOfImage(*((ZnImage *) valp));
@@ -1256,7 +1267,7 @@ ZnQueryAttribute(Tcl_Interp     *interp,
   if (!desc) {
     return TCL_ERROR;
   }
-  AttributeToObj(interp, record, desc, Tcl_GetObjResult(interp));
+  AttributeToObj(interp, record, desc);
 
   return TCL_OK;
 }
-- 
cgit v1.1