Changeset 57e34db in tol for tolbase/lib

Timestamp:

Mar 24, 2010, 10:37:02 PM (17 years ago)

Author:

Jorge Pérez <josp.jorge@…>

Branches:

1941-docker-image-to-test, devel, master

Children:

320d511

Parents:

03885938

Message:

closes #885, un elemento de menu retornado por getMenuEntries sigue la
siguiente estructura:

  [[ "Option Label", "Instance_Method", "Group_Method" ]]

donde:

"Option Label" es la etiqueta que se muestra en el menu

"Instance_Method" es el nombre del metodo de instancia que se invoca

al seleccionar la opcion de menu.

"Group_Method" es el nombre de metodo estatico que se invoca cuando

se aplica la opcion de menu sobre una seleccion
multiple. Este valor es opcional.

por ejemplo las variables de MMS implementan el el metodo:

   Set getMenuEntries(Real void) {
    Set [[ [[ "Chart", "Chart", "ChartGroup" ]] ]]
   }

y las clases derivadas deben implementar el metodo de instancia Chart
y el metodo Static ChartGroup con el siguiente prototipo:

  Real Chart( Real void )

  Static Real ChartGroup( Set instances )

git-svn-id: ​https://www.tol-project.org/svn/tolp/trunk@2061 be4846ae-f051-483a-831f-b64e7d08527f

File:

• tolbase/lib/toltk/tolinspe.tcl (modified) (7 diffs)

tolbase/lib/toltk/tolinspe.tcl

@@ -1828 +1828 @@
 proc Tol_ObjIsClassOf { obj_addr cls_name } {
   tol::console eval [ string map [ list %A $obj_addr %C $cls_name ] {
-    Real __gui_check__ = IsInstanceOf(GetObjectFromAddress("%A"),"%C")
+    Real __gui_check__ = IsInstanceOf( GetObjectFromAddress( "%A" ),"%C" )
   } ]
   set info [ tol::info variable {Real __gui_check__} ]
@@ -1836 +1836 @@
 }
 
-proc TolGui_GetMenuEntries { obj_addr } {
+proc Tol_ClassOf { obj_addr } {
+  tol::console eval [ string map [ list %A $obj_addr ] {
+    Text __gui_classof__ = {
+      Anything obj = GetObjectFromAddress( "%A" );
+      // WriteLn( "Tol_ClassOf " << Grammar( obj ) );
+      Text If( Grammar( obj ) == "NameBlock", ClassOf( obj ), "" )
+    }
+  } ]
+  set info [ tol::info variable {Text __gui_classof__} ]
+  set x [ string trim [ lindex $info 2 ]  \" ]
+  tol::console stack release __gui_classof__
+  set x
+}
+
+proc TolGui_GetMenuEntries { selection idx } {
+  array set instances {}
+  array set menu_class {}
+  set i 0
+  foreach obj_info $selection {
+    set tcl_ref [ lindex $obj_info 0 ]
+    set obj_addr [ ::tol::info address $tcl_ref ]
+    set class [ Tol_ClassOf $obj_addr ]
+    if { $class ne "" } {
+      lappend instances($class) $obj_addr
+      set name_inst [ lindex $obj_info 1 ]
+      set menu_items [ TolGui_GetObjMenu $obj_addr ]
+      # esto hace que estemos guardando la ultima instancia, asumimos
+      # tambien que todas las instancia tienen la misma espcificacion
+      # de menu
+      if { ![ llength [ array names menu_class $class ] ] || $i == $idx } {
+        set menu_class($class) \
+            [ list $name_inst $obj_addr $menu_items ]
+      }
+    }
+    incr i
+  }
+  set menu_info [ list ]
+  foreach c [ array names instances ] {
+      lappend menu_info [ list $c $menu_class($c) $instances($c) ]
+  }
+  set menu_info
+}
+
+proc TolGui_GetObjMenu { obj_addr } {
   set try [ catch {
     tol::console eval [ string map [ list %A $obj_addr ] {
@@ -1853 +1896 @@
 }
 
-proc TolGui_InvokeMethod { obj_addr method } {
+proc TolGui_InvokeMethod { method obj_addr } {
   set try [ catch {
     tol::console eval [ string map [ list %A $obj_addr %M $method ] {
@@ -1866 +1909 @@
 }
 
+proc TclList2SetOfText { lst } {
+  set result [ list ]
+  foreach i $lst {
+    lappend result \"$i\"
+  }
+  return "SetOfText([join $result ,])"
+}
+
+proc TolGui_InvokeGroup { cname function group } {
+  set SOA [ TclList2SetOfText $group ]
+  set try [ catch {
+    tol::console eval \
+        [ string map [ list %C $cname %F $function %S $SOA ] {
+          Real __aux_result__ = %C::%F( %S )
+        } ] } msg ]
+  if { $try } {
+    puts "ERROR TolGui_InvokeGroup : $msg"
+  }
+  tol::console stack release __aux_result__
+}
+
 #/////////////////////////////////////////////////////////////////////////////
 proc ::TolInspector::PostVariable { x y } {
@@ -1901 +1965 @@
   #puts "PostVariable: InRootConsole,InRootPool,InRootFiles = $InRootConsole,$InRootPool,$InRootFiles"
   set node_act [$ht_vars index current]
-  if { [string length $node_act] } {      
+  if { [string length $node_act] } {
     set vars_selected [$ht_vars curselection]
     if { [lsearch $vars_selected $node_act] >= 0 } {
@@ -1917 +1981 @@
           if {[llength $aryData(Reference)]} {
             #set object [lindex $aryData(Reference) 0]
-                        set object [lrange $aryData(Reference) 0 end]
+            set object [lrange $aryData(Reference) 0 end]
           } else {
             if { [string length $tolset] } {
@@ -2062 +2126 @@
             NameBlock {
               if { [ llength $options_selected(NameBlock) ] } {
-                puts "ooo = $options_selected(NameBlock)"
-                set obj_info [ lindex $options_selected(NameBlock) 0 ]
-                set tcl_ref [ lindex $obj_info 0 ]
-                set obj_addr [ ::tol::info address $tcl_ref ]
-                puts "obj_addr $obj_addr"
-                if { [ Tol_ObjIsClassOf $obj_addr "@MenuDesc" ] } {
-                  set entries [ TolGui_GetMenuEntries $obj_addr ]
-                  foreach ent $entries {
-                    $data_menu(main) add command -label [ lindex $ent 0 ] \
+                set idx_current [ lsearch $vars_selected $node_act ]
+                foreach mi [ TolGui_GetMenuEntries \
+                                 $options_selected(NameBlock) $idx_current ] {
+                  set _cname [ lindex $mi 0 ]
+                  set cname [ string map [ list @ "" . _ ] $_cname ]
+                  foreach { ninst obj_addr entries } [ lindex $mi 1 ] break
+                  set instances [ lindex $mi 2 ]
+                  # creo el menu de la clase si no existe
+                  set mclass $data_menu(main).cls$cname
+                  if { ![ winfo exists $mclass ] } {
+                    menu $data_menu(main).cls$cname -tearoff 0
+                  } else {
+                    $mclass delete 0 end
+                  }
+                  $data_menu(main) add cascade -label $cname -menu $mclass
+                  foreach inst_entry $entries {
+                    foreach { label single group } $inst_entry break
+                    $mclass add command -label "$label $ninst" \
                         -command [ list TolGui_InvokeMethod \
-                                       $obj_addr  [ lindex $ent 1 ] ]
+                                       $single $obj_addr ]
+                    if { $group ne "" && [ llength $instances ] > 1 } {
+                      # hay una funcion que se aplica a toda la seleccion
+                      $mclass add command -label "$label All" \
+                          -command [ list TolGui_InvokeGroup \
+                                         $_cname $group $instances ]
+                    }
                   }
                 }