Index: tolbase/lib/toltk/tclIndex =================================================================== --- tolbase/lib/toltk/tclIndex (revision be261c8255282c561bc91b0497dd203aa41e62e7) +++ tolbase/lib/toltk/tclIndex (revision 7a3f24e9fd698b7478644e5f73c3a75a53e4de3e) @@ -331,69 +331,69 @@ set auto_index(::TolInspector::OneLine) [list source [file join $dir tolinspe.tcl]] set auto_index(::TolInspector::TrimContent) [list source [file join $dir tolinspe.tcl]] -set auto_index(::TolInspector::_InsertChild) [list source [file join $dir tolinspe.tcl]] -set auto_index(::TolInspector::InsertChild) [list source [file join $dir tolinspe.tcl]] -set auto_index(::TolInspector::Insert_HTItem) [list source [file join $dir tolinspe.tcl]] -set auto_index(::TolInspector::ClearHiertables) [list source [file join $dir tolinspe.tcl]] -set auto_index(::TolInspector::getPackageReference) [list source [file join $dir tolinspe.tcl]] -set auto_index(::TolInspector::OpenObject) [list source [file join $dir tolinspe.tcl]] -set auto_index(::TolInspector::InsertPackages) [list source [file join $dir tolinspe.tcl]] -set auto_index(::TolInspector::InsertGrammars) [list source [file join $dir tolinspe.tcl]] -set auto_index(::TolInspector::InsertFiles) [list source [file join $dir tolinspe.tcl]] -set auto_index(::TolInspector::InsertConsoleObj) [list source [file join $dir tolinspe.tcl]] -set auto_index(::TolInspector::InsertPoolObj) [list source [file join $dir tolinspe.tcl]] +set auto_index(::TolInspector::_InsertChild) [list source [file join $dir tolinspe_wtree1.tcl]] +set auto_index(::TolInspector::InsertChild) [list source [file join $dir tolinspe_wtree1.tcl]] +set auto_index(::TolInspector::Insert_HTItem) [list source [file join $dir tolinspe_wtree1.tcl]] +set auto_index(::TolInspector::ClearHiertables) [list source [file join $dir tolinspe_wtree1.tcl]] +set auto_index(::TolInspector::getPackageReference) [list source [file join $dir tolinspe_wtree1.tcl]] +set auto_index(::TolInspector::OpenObject) [list source [file join $dir tolinspe_wtree1.tcl]] +set auto_index(::TolInspector::InsertPackages) [list source [file join $dir tolinspe_wtree1.tcl]] +set auto_index(::TolInspector::InsertGrammars) [list source [file join $dir tolinspe_wtree1.tcl]] +set auto_index(::TolInspector::InsertFiles) [list source [file join $dir tolinspe_wtree1.tcl]] +set auto_index(::TolInspector::InsertConsoleObj) [list source [file join $dir tolinspe_wtree1.tcl]] +set auto_index(::TolInspector::InsertPoolObj) [list source [file join $dir tolinspe_wtree1.tcl]] set auto_index(::TolInspector::FilterNameBlockMember) [list source [file join $dir tolinspe.tcl]] -set auto_index(::TolInspector::InsertSubset) [list source [file join $dir tolinspe.tcl]] -set auto_index(::TolInspector::ClearConsoleObj) [list source [file join $dir tolinspe.tcl]] -set auto_index(::TolInspector::ClearConsoleObjSel) [list source [file join $dir tolinspe.tcl]] -set auto_index(::TolInspector::UpdateFileRoot) [list source [file join $dir tolinspe.tcl]] -set auto_index(::TolInspector::UpdateConsoleObj) [list source [file join $dir tolinspe.tcl]] -set auto_index(::TolInspector::UpdatePoolObj) [list source [file join $dir tolinspe.tcl]] -set auto_index(::TolInspector::SelectObject) [list source [file join $dir tolinspe.tcl]] -set auto_index(::TolInspector::SelectFileRoot) [list source [file join $dir tolinspe.tcl]] -set auto_index(::TolInspector::SelectConsoleRoot) [list source [file join $dir tolinspe.tcl]] -set auto_index(::TolInspector::SelectPoolRoot) [list source [file join $dir tolinspe.tcl]] -set auto_index(::TolInspector::SelectGrammar) [list source [file join $dir tolinspe.tcl]] -set auto_index(::TolInspector::SelectSet) [list source [file join $dir tolinspe.tcl]] +set auto_index(::TolInspector::InsertSubset) [list source [file join $dir tolinspe_wtree1.tcl]] +set auto_index(::TolInspector::ClearConsoleObj) [list source [file join $dir tolinspe_wtree2.tcl]] +set auto_index(::TolInspector::ClearConsoleObjSel) [list source [file join $dir tolinspe_wtree2.tcl]] +set auto_index(::TolInspector::UpdateFileRoot) [list source [file join $dir tolinspe_wtree2.tcl]] +set auto_index(::TolInspector::UpdateConsoleObj) [list source [file join $dir tolinspe_wtree2.tcl]] +set auto_index(::TolInspector::UpdatePoolObj) [list source [file join $dir tolinspe_wtree2.tcl]] +set auto_index(::TolInspector::SelectObject) [list source [file join $dir tolinspe_wtree1.tcl]] +set auto_index(::TolInspector::SelectFileRoot) [list source [file join $dir tolinspe_wtree1.tcl]] +set auto_index(::TolInspector::SelectConsoleRoot) [list source [file join $dir tolinspe_wtree1.tcl]] +set auto_index(::TolInspector::SelectPoolRoot) [list source [file join $dir tolinspe_wtree1.tcl]] +set auto_index(::TolInspector::SelectGrammar) [list source [file join $dir tolinspe_wtree1.tcl]] +set auto_index(::TolInspector::SelectSet) [list source [file join $dir tolinspe_wtree1.tcl]] set auto_index(::TolInspector::GetParentGrammar) [list source [file join $dir tolinspe.tcl]] -set auto_index(::TolInspector::CloseObject) [list source [file join $dir tolinspe.tcl]] +set auto_index(::TolInspector::CloseObject) [list source [file join $dir tolinspe_wtree1.tcl]] set auto_index(::TolInspector::HasSubset) [list source [file join $dir tolinspe.tcl]] -set auto_index(::TolInspector::OpenVariable) [list source [file join $dir tolinspe.tcl]] -set auto_index(::TolInspector::SelectItem) [list source [file join $dir tolinspe.tcl]] -set auto_index(::TolInspector::FillText) [list source [file join $dir tolinspe.tcl]] +set auto_index(::TolInspector::OpenVariable) [list source [file join $dir tolinspe_wtree1.tcl]] +set auto_index(::TolInspector::SelectItem) [list source [file join $dir tolinspe_wtree1.tcl]] +set auto_index(::TolInspector::FillText) [list source [file join $dir tolinspe_wtree1.tcl]] set auto_index(::TolInspector::GetItemName) [list source [file join $dir tolinspe.tcl]] set auto_index(::TolInspector::OnBusy) [list source [file join $dir tolinspe.tcl]] set auto_index(::TolInspector::Busy) [list source [file join $dir tolinspe.tcl]] set auto_index(::TolInspector::NotBusy) [list source [file join $dir tolinspe.tcl]] -set auto_index(Tol_ObjIsClassOf) [list source [file join $dir tolinspe.tcl]] -set auto_index(Tol_ClassOf) [list source [file join $dir tolinspe.tcl]] -set auto_index(Tol_ClassOfFromReference) [list source [file join $dir tolinspe.tcl]] -set auto_index(TolGui_GetMenuEntries) [list source [file join $dir tolinspe.tcl]] -set auto_index(TolGui_InsertEntriesFromMenuManager) [list source [file join $dir tolinspe.tcl]] -set auto_index(TolGui_GetObjMenu) [list source [file join $dir tolinspe.tcl]] -set auto_index(TolGui_InvokeMethod) [list source [file join $dir tolinspe.tcl]] -set auto_index(TclList2SetOfText) [list source [file join $dir tolinspe.tcl]] -set auto_index(TolGui_InvokeGroup) [list source [file join $dir tolinspe.tcl]] -set auto_index(::TolInspector::PostVariable) [list source [file join $dir tolinspe.tcl]] -set auto_index(::TolInspector::PostFunction) [list source [file join $dir tolinspe.tcl]] -set auto_index(::TolInspector::PostTree) [list source [file join $dir tolinspe.tcl]] -set auto_index(::TolInspector::RemoveFromSpool) [list source [file join $dir tolinspe.tcl]] -set auto_index(::TolInspector::AddToSpool) [list source [file join $dir tolinspe.tcl]] -set auto_index(::TolInspector::AddToEvalWindow) [list source [file join $dir tolinspe.tcl]] -set auto_index(::TolInspector::SelectAll) [list source [file join $dir tolinspe.tcl]] -set auto_index(::TolInspector::ToggleSelection) [list source [file join $dir tolinspe.tcl]] -set auto_index(::TolInspector::DrawSet) [list source [file join $dir tolinspe.tcl]] -set auto_index(::TolInspector::DrawMatrix) [list source [file join $dir tolinspe.tcl]] -set auto_index(::TolInspector::TableSet) [list source [file join $dir tolinspe.tcl]] -set auto_index(::TolInspector::TableMatrix) [list source [file join $dir tolinspe.tcl]] -set auto_index(::TolInspector::ExportBDTMatrix) [list source [file join $dir tolinspe.tcl]] -set auto_index(::TolInspector::DrawSerie) [list source [file join $dir tolinspe.tcl]] -set auto_index(::TolInspector::DrawSeries) [list source [file join $dir tolinspe.tcl]] -set auto_index(::TolInspector::DrawAutocorSerie) [list source [file join $dir tolinspe.tcl]] -set auto_index(::TolInspector::TableSerie) [list source [file join $dir tolinspe.tcl]] -set auto_index(::TolInspector::TableAutocorSerie) [list source [file join $dir tolinspe.tcl]] -set auto_index(::TolInspector::TableStatisticsSerie) [list source [file join $dir tolinspe.tcl]] -set auto_index(::TolInspector::ViewTimeSet) [list source [file join $dir tolinspe.tcl]] -set auto_index(::TolInspector::ViewDefinition) [list source [file join $dir tolinspe.tcl]] -set auto_index(::TolInspector::ViewFile) [list source [file join $dir tolinspe.tcl]] +set auto_index(Tol_ObjIsClassOf) [list source [file join $dir tolinspe__tolgui.tcl]] +set auto_index(Tol_ClassOf) [list source [file join $dir tolinspe__tolgui.tcl]] +set auto_index(Tol_ClassOfFromReference) [list source [file join $dir tolinspe__tolgui.tcl]] +set auto_index(TolGui_GetMenuEntries) [list source [file join $dir tolinspe__tolgui.tcl]] +set auto_index(TolGui_InsertEntriesFromMenuManager) [list source [file join $dir tolinspe__tolgui.tcl]] +set auto_index(TolGui_GetObjMenu) [list source [file join $dir tolinspe__tolgui.tcl]] +set auto_index(TolGui_InvokeMethod) [list source [file join $dir tolinspe__tolgui.tcl]] +set auto_index(TclList2SetOfText) [list source [file join $dir tolinspe__tolgui.tcl]] +set auto_index(TolGui_InvokeGroup) [list source [file join $dir tolinspe__tolgui.tcl]] +set auto_index(::TolInspector::PostVariable) [list source [file join $dir tolinspe__wtree2.tcl]] +set auto_index(::TolInspector::PostFunction) [list source [file join $dir tolinspe__wtree2.tcl]] +set auto_index(::TolInspector::PostTree) [list source [file join $dir tolinspe__wtree2.tcl]] +set auto_index(::TolInspector::RemoveFromSpool) [list source [file join $dir tolinspe__wtree2.tcl]] +set auto_index(::TolInspector::AddToSpool) [list source [file join $dir tolinspe__wtree2.tcl]] +set auto_index(::TolInspector::AddToEvalWindow) [list source [file join $dir tolinspe__wtree2.tcl]] +set auto_index(::TolInspector::SelectAll) [list source [file join $dir tolinspe__wtree2.tcl]] +set auto_index(::TolInspector::ToggleSelection) [list source [file join $dir tolinspe__wtree2.tcl]] +set auto_index(::TolInspector::DrawSet) [list source [file join $dir tolinspe__draw.tcl]] +set auto_index(::TolInspector::DrawMatrix) [list source [file join $dir tolinspe__draw.tcl]] +set auto_index(::TolInspector::TableSet) [list source [file join $dir tolinspe__draw.tcl]] +set auto_index(::TolInspector::TableMatrix) [list source [file join $dir tolinspe__draw.tcl]] +set auto_index(::TolInspector::ExportBDTMatrix) [list source [file join $dir tolinspe__draw.tcl]] +set auto_index(::TolInspector::DrawSerie) [list source [file join $dir tolinspe__draw.tcl]] +set auto_index(::TolInspector::DrawSeries) [list source [file join $dir tolinspe__draw.tcl]] +set auto_index(::TolInspector::DrawAutocorSerie) [list source [file join $dir tolinspe__draw.tcl]] +set auto_index(::TolInspector::TableSerie) [list source [file join $dir tolinspe__draw.tcl]] +set auto_index(::TolInspector::TableAutocorSerie) [list source [file join $dir tolinspe__draw.tcl]] +set auto_index(::TolInspector::TableStatisticsSerie) [list source [file join $dir tolinspe__draw.tcl]] +set auto_index(::TolInspector::ViewTimeSet) [list source [file join $dir tolinspe__draw.tcl]] +set auto_index(::TolInspector::ViewDefinition) [list source [file join $dir tolinspe__draw.tcl]] +set auto_index(::TolInspector::ViewFile) [list source [file join $dir tolinspe__draw.tcl]] set auto_index(::TolInspector::DecompileFile) [list source [file join $dir tolinspe.tcl]] set auto_index(::TolInspector::ReadUserFunctions) [list source [file join $dir tolinspe.tcl]] Index: lbase/lib/toltk/tolinspe.tcl =================================================================== --- tolbase/lib/toltk/tolinspe.tcl (revision be261c8255282c561bc91b0497dd203aa41e62e7) +++ (revision ) @@ -1,3821 +1,0 @@ -#///////////////////////////////////////////////////////////////////////////// -# FILE : tolinspe.tcl -# PURPOSE : This file contains a namespace called TolInspector with its -# functions. Its for creating a the TOL object inspector and -# managing its events. -#///////////////////////////////////////////////////////////////////////////// - -package require bguifunction -package require snit -package require btable - -if { 0 && ![info exists toltk_script_path] } { - set toltk_script_path [file dirname [info script]] - source [file join $toltk_script_path init_toltk.tcl] -} - -if {"unix" eq $::tcl_platform(platform)} { - foreach "but units" [list 4 -5 5 5] { - set comm [string map "%d $units" { - %W yview scroll %d units - }] - bind TreeView <$but> $comm - } -} else { - bind TreeView { - %W yview scroll [expr int(-1*%D/36)] units - } -} -# -##///////////////////////////////////////////////////////////////////////////// -#proc dump { args } { -## -## PURPOSE: Auxiliary procedure to show a string -## -##///////////////////////////////////////////////////////////////////////////// -#puts $args -#} - -#///////////////////////////////////////////////////////////////////////////// -proc startupResources { } { -# -# PURPOSE: Establishes the preferences of the inspector -# -#///////////////////////////////////////////////////////////////////////////// - global tcl_platform - global toltk_options - DynamicHelp::configure -background #FFFFC0 - if {[string equal $tcl_platform(platform) "windows"]} { - set toltk_options(colors,SystemButtonFace) SystemButtonFace - set toltk_options(fonts,MenuNor) {Tahoma 8} - set toltk_options(fonts,Fixed) {{Courier New} 9} - set toltk_options(fonts,FixSmall) {{Courier New} 8} - set toltk_options(fonts,Title1) {Arial 9 bold} - set toltk_options(fonts,Label) {Arial 9} - set toltk_options(fonts,TxtSmall) {Arial 8} - set toltk_options(relief,ridge) ridge - } else { - set toltk_options(colors,SystemButtonFace) #d4d4d4 - set toltk_options(fonts,MenuNor) {-*-helvetica-medium-r} - set toltk_options(fonts,Fixed) {Courier 9} - set toltk_options(fonts,FixSmall) {-*-courier-small-r} - set toltk_options(fonts,Title1) {-*-helvetica-bold-r} - set toltk_options(fonts,Label) {-*-helvetica-medium-r} - set toltk_options(fonts,TxtSmall) {-*-helvetica-small-r} - set toltk_options(relief,ridge) raised - } - option add *background $toltk_options(colors,SystemButtonFace) user - option add *Label.font $toltk_options(fonts,Label) user - option add *Radiobutton.font $toltk_options(fonts,Label) user - option add *Checkbutton.font $toltk_options(fonts,Label) user - option add *Button.font $toltk_options(fonts,Label) user - option add *Menu.font $toltk_options(fonts,MenuNor) user - option add *TitleFrame.l.font $toltk_options(fonts,Title1) user - option add *Tabset.selectForeground black user - - option readfile [file join $::toltk_script_path toltk.rc] user -} - -#///////////////////////////////////////////////////////////////////////////// -namespace eval ::TolInspector { -# -# PURPOSE: The purpose of this namespace is creating a the TOL object -# inspector and managing its events. -# VARIABLES: -# data: -# regFunLst: List array with functions defined by user -# tolset: Name of the current TOL set variable -# tolindex: -# at_set: -# node_prefix: -# ht_tree: Tree widget containing the TOL objects (:blt::treeview) -# blt_tree: Tree widget containing the TOL objects (:blt::tree) -# w_tabset: Tabset widget containing trees of variables and functions -# ht_vars: Tree widget containing the tree of Variables -# (:blt::treeview) -# blt_vartree: Tree widget containing the tree of Variables (:blt::tree) -# data_menu: Array with data of menus -# group_id: -# ht_funcs: Tree widget containing the tree of Functions -# (:blt::treeview) -# blt_functree: Tree widget containing the tree of Functions (:blt::tree) -# item_data: Array to hold the full content & description of items -# item_id: Current index of item to insert in ht_* starting from 1 -# OnSelectItem: Command to invoke on SelectItem in ht_* -# OnBusyCmd: Command to invoke when busy -# SubTypeImgs: Images associated to types of set -# -#///////////////////////////////////////////////////////////////////////////// - variable data - - # List array with functions defined by user - variable regFunLst - - # name of the current TOL set variable. - variable tolset "" - variable tolindex "" - # estas variables desapareceran cuando ::tol::forallchild admita scripts - # completos y no solo nombres de proc - variable at_set - variable node_prefix - - variable iterSet "" - variable knownReference "" - - variable gra_parent "" - # tree widget containing the TOL objects. - variable ht_tree ;# is a ::blt::treeview - variable blt_tree ;# is a ::blt::tree - - # tabset widget containing trees of variables and functions - variable w_tabset - - # list widget containing the variables. It's the window of - # the tab Variable - variable ht_vars ;# is a ::blt::treeview - variable blt_vartree ;# is a ::blt::tree - - variable data_menu - variable group_id -1 - - # list widget containing the functions. It's the window of - # the tab Functions - variable ht_funcs ;# is a ::blt::treeview - variable blt_functree ;# is a ::blt::tree - - # array to hold the full content & description of items - variable item_data - - # current index of item to insert in ht_* starting from 1 - variable item_id - - # tell if we are processing a SelectSet event - - #variable selecting_set - #variable closing - - # command to invoke on SelectItem in ht_* - variable OnSelectItem - - # command to invoke when busy - variable OnBusyCmd "" - - # images associated to types of set. - variable SubTypeImgs { - GenericSet MODFile PRJFile DIRFile TOLFile - BDCFile BDTFile BSTFile BMTFile BSIFile TSIFile BMIFile - StructuredSet TableSet} - -} - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::SubTypeImage { idx } { -#///////////////////////////////////////////////////////////////////////////// - variable SubTypeImgs - - #Tolcon_Trace "SubTypeImage $idx = [lindex $SubTypeImgs $idx]" - ::Bitmap::get [lindex $SubTypeImgs $idx] -} - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::CreateColumns { ht } { -# -# PURPOSE: Creates the columns (index, name, content, path, description ) -# of the tree of variables or functions -# -# PARAMETERS: -# ht: path of ::blt::treeview of variables or ::blt::treeview of functions -# -#///////////////////////////////////////////////////////////////////////////// - # main column ==> Name - $ht column configure treeView -text [mc "Name"] -justify left \ - -bg white -activetitlebackground gray90 -pad 3 - # index column - $ht column insert 0 Index \ - -bg white -justify left -activetitlebackground gray90 - # columns Content Path & Description - #(pgea) se oculta la columna correspondiente a la referencia - $ht column insert end Content Description Path\ - -bg white -justify left -activetitlebackground gray90 -pad 3 - $ht column insert end Reference -hide yes - foreach c {Index Content Description Path} { - $ht column configure $c -text [mc "$c"] - } - # associates the command of order to each one of the titles of the - # columns of the trees - foreach column [$ht column names] { - $ht column configure $column \ - -command [list ::TolInspector::SortColumn $ht $column] - } -} - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::SortColumn {ht column} { -# -# PURPOSE: Associates the command of order to the title of a column of the -# tree of variables or the tree of functions -# -# PARAMETERS: -# ht: path of ::blt::treeview of variables or ::blt::treeview of -# functions -# column: name of the column of this tree -# -#///////////////////////////////////////////////////////////////////////////// - set old [$ht sort cget -column] - set decreasing 0 - if { "$old" == "$column" } { - set decreasing [$ht sort cget -decreasing] - set decreasing [expr !$decreasing] - } - $ht sort configure -decreasing $decreasing -column $column -mode integer - $ht configure -flat no - $ht sort auto yes - - blt::busy hold $ht - update - blt::busy release $ht -} - - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::Create { w args } { -# -# PURPOSE: Creates the object inspector, that contains two panels with three -# treeviews and three trees. -# - One for the left side of the inspector (with grammars, -# included files, console objects and object's spool) -# - And two for the right one (one for variables tab and one for -# functions tab) -# -# PARAMETERS: -# w: path where tol inspector must be created -# args: list of pairs {-option value} with options for the inspector. -# -onselcmd Comand to execute when a node is selected -# -wleft relative weight of left pane -# -wrigth relative weight of rigth pane -# -#///////////////////////////////////////////////////////////////////////////// - global toltk_options - variable ht_tree - variable blt_tree - variable ht_vars - variable blt_vartree - variable data_menu - variable ht_funcs - variable blt_functree - variable w_tabset - variable OnSelectItem - variable OnBusyCmd "" - - # this should be used insted of a lot of scalar variables. - # but, what can we do now? - - variable widgets - variable data - - array set data { - pool,objects "" - } - - array set options { - -onselcmd "" - -wleft 3 - -wright 7 - } - array set options $args - - # initializes the command OnSelectItem to "" - set OnSelectItem $options(-onselcmd) - - #variable selecting_set 0 - #variable closing 0 - - #upvar \#0 ::TolTk::Images Images - - # creation of PANED WINDOW MAIN - set pwMain [PanedWindow $w -side bottom -pad 0 -width 4] - # creation of pane left and pane right - set paneLeft [$pwMain add -weight $options(-wleft)] - set paneRight [$pwMain add -weight $options(-wright)] - set widgets(panes,left) $paneLeft - set widgets(panes,right) $paneRight - - # when a panel is destroyed, the item 'geometry,side' of the array variable - # data gives the value of the width of panel 'side' (left or right) - bind $paneLeft { - namespace eval ::TolInspector { - variable data - variable widgets - set data(geometry,left) [winfo width $widgets(panes,left)] - } - } - bind $paneRight { - namespace eval ::TolInspector { - variable data - variable widgets - set data(geometry,right) [winfo width $widgets(panes,right)] - } - } - # bind for destruction of paned window main - bind $pwMain ::TolInspector::Destroy - - # creation of pane left with tree with the TOL OBJECTS - CreatePaneLeft $paneLeft - # creation of the right panel with TABSET of VARIABLES and FUNCTIONS - CreatePaneRight $paneRight - # creation of the menus - CreateMenus - # packing the panedwindowmain - pack $pwMain -fill both -expand yes - - # esto es para evitar que aparezca el icono open cuando - # relleno estando el mouse sobre ht_* - $ht_vars bind Entry "" - $ht_vars bind Entry "" - $ht_funcs bind Entry "" - $ht_funcs bind Entry "" -} - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::CreatePaneLeft { paneLeft } { -# -# PURPOSE: Creation of TREE LEFT with the TOL OBJECTS -# -# PARAMETERS: -# paneLeft: path of the pane of the left in TolInspector -# -#///////////////////////////////////////////////////////////////////////////// - global toltk_options - variable blt_tree - variable ht_tree - - # creation of the ScrolledWindow of the left side - set sw1 [ScrolledWindow $paneLeft.sw -ipad 0 -borderwidth 0 -scrollbar both ] - # creation of the left tree - set blt_tree [::blt::tree create tree$sw1.ht] - set ht_tree [::blt::treeview $sw1.ht -tree $blt_tree -bg white \ - -hideroot no -activeicons "" \ - -selectbackground gray75 -selectforeground black \ - -selectcommand ::TolInspector::SelectObject \ - -highlightthickness 0 -font $toltk_options(fonts,Label)] - # configuration of the left tree - $ht_tree configure \ - -closecommand "::TolInspector::CloseObject %#" \ - -opencommand "::TolInspector::OpenObject %#" - $ht_tree style configure text -bg white - $ht_tree column configure treeView -bg white - $ht_tree column insert end FileName -hide true - # creation of the root node "Tol Objects" - set img [::Bitmap::get Objects] - $ht_tree entry configure root -label [mc "Tol Objects"]\ - -icons [list $img $img] - - # creation of the node father "Grammars" - set img [::Bitmap::get Grammars] - set blt_idx [$blt_tree insert root -label "root-grammars"\ - -tags "root-grammars"] - $ht_tree entry configure $blt_idx -label [mc "Grammars"]\ - -icons [list $img $img] - # Inserts in the node of grammars a node by each grammar that exists in Tol - InsertGrammars - - # creation of the node father "Packages" - set img [::Bitmap::get "package"] - set blt_idx [$blt_tree insert root -label "root-packages"\ - -tags "root-packages"] - $ht_tree entry configure $blt_idx -label [mc "Packages"]\ - -icons [list $img $img] -button yes - - # creation of the node father "Included Files" - set img [::Bitmap::get "Files"] - set blt_idx [$blt_tree insert root -label "root-files" -tags "root-files"] - $ht_tree entry configure $blt_idx -label [mc "Included Files"] \ - -icons [list $img $img] -button yes - # creation of the node father "Console Objects" - set img [::Bitmap::get "Console"] - set blt_idx [$blt_tree insert root -label "root-console"\ - -tags "root-console"] - $ht_tree entry configure $blt_idx -label [mc "Console Objects"] \ - -icons [list $img $img] -button yes - # creation of the node father "Objects' Spool" - set img [::Bitmap::get "pool"] - set blt_idx [$blt_tree insert root -label "root-pool" -tags "root-pool"] - $ht_tree entry configure $blt_idx -label [mc "Objects' Spool"] \ - -icons [list $img $img] -button yes - # associates the tree to scrolled window - $sw1 setwidget $ht_tree - # packing - pack $sw1 -fill both -expand yes - # bind the focus on tree - bind $ht_tree "::focus $ht_tree" -} - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::CreatePaneRight { paneRight } { -# -# PURPOSE: Creation of the right pane with TABSET with VARIABLES and FUNCTIONS -# -# PARAMETERS: -# paneLeft: path of the pane of the right in TolInspector -# -#///////////////////////////////////////////////////////////////////////////// - global toltk_options - variable w_tabset - variable blt_vartree - variable ht_vars - variable blt_functree - variable ht_funcs - - # creates the tabset to display the variables & functions - #set w_tabset [::blt::tabset $paneRight.ts -relief flat\ - -bd 0 -outerpad 0 -tier 2 -slant none -textside top \ - -highlightthickness 0 -side left -rotate 90] - set w_tabset [::blt::tabset $paneRight.ts -relief flat\ - -bd 0 -outerpad 0 -tier 2 -slant right -textside right \ - -highlightthickness 0] - # creates the scrolled windows for each one of the tabs - set sw21 [ScrolledWindow $w_tabset.sw1] - set sw22 [ScrolledWindow $w_tabset.sw2] - # inserts in the tabset the tabs of functions and variables - $w_tabset insert end \ - Variables -text [mc Variables] -selectbackground \#d9d9d9 -bg gray75 \ - -image [::Bitmap::get Variables] -pady 0\ - Functions -text [mc Functions] -selectbackground \#d9d9d9 -bg gray75 \ - -image [::Bitmap::get Functions] -pady 0 - - # Creation of the right TREE RIGHT with VARIABLES - set blt_vartree [::blt::tree create tree$sw21.vars] - set ht_vars [::blt::treeview $sw21.vars -tree $blt_vartree -flat no\ - -bg white -hideroot yes -linewidth 0 -activeicons {}\ - -selectmode multiple\ - -selectbackground gray75 -selectforeground black \ - -highlightthickness 0 -font $toltk_options(fonts,Label)] - #tv_ordered_selection tvsel -tv $ht_vars - # configuration of the tree of variables - $ht_vars configure \ - -opencommand "::TolInspector::OpenVariable %#" \ - -selectcommand "::TolInspector::SelectItem $ht_vars" - $ht_vars style configure text -bg white - bind $ht_vars "::focus $ht_vars" - - # Creation of the right TREE RIGHT with FUNCTIONS - set blt_functree [::blt::tree create tree$sw22.funcs] - set ht_funcs [::blt::treeview $sw22.funcs -tree $blt_functree -flat no\ - -bg white -hideroot yes -linewidth 0 -activeicons {} \ - -selectmode multiple\ - -selectbackground gray75 -selectforeground black \ - -highlightthickness 0 -font $toltk_options(fonts,Label)] - # configuration of the tree of functions - $ht_funcs configure -selectcommand "::TolInspector::SelectItem $ht_funcs" - $ht_funcs style configure text -bg white - bind $ht_funcs "::focus $ht_funcs" - - # associates the trees to scrolled windows - $sw21 setwidget $ht_vars - $sw22 setwidget $ht_funcs - # configure the tabs - $w_tabset tab configure Variables -window $sw21 -fill both -padx 0 - $w_tabset tab configure Functions -window $sw22 -fill both -padx 0 - # create the columns of the trees of variables and functions - CreateColumns $ht_vars - CreateColumns $ht_funcs - # packing the tabset - pack $w_tabset -fill both -expand yes - $w_tabset tab configure Variables\ - -command "::TolInspector::SelectItem $ht_vars" - $w_tabset tab configure Functions\ - -command "::TolInspector::SelectItem $ht_funcs" -} - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::CreateMenus {} { -# -# PURPOSE: Create the menus of the trees -# -#///////////////////////////////////////////////////////////////////////////// - variable data_menu - variable ht_vars - variable ht_funcs - variable ht_tree - - set data_menu(main) [menu $ht_vars.m -tearoff 0] - set data_menu(Code,File) [menu $data_menu(main).mcof -tearoff 0] - set data_menu(Complex,File) [menu $data_menu(main).mcxf -tearoff 0] - set data_menu(Date,File) [menu $data_menu(main).mdaf -tearoff 0] - set data_menu(Matrix,File) [menu $data_menu(main).mmaf -tearoff 0] - set data_menu(VMatrix,File) [menu $data_menu(main).mvmf -tearoff 0] - set data_menu(Polyn,File) [menu $data_menu(main).mpof -tearoff 0] - set data_menu(Ratio,File) [menu $data_menu(main).mraf -tearoff 0] - set data_menu(Real,File) [menu $data_menu(main).mref -tearoff 0] - set data_menu(Serie,File) [menu $data_menu(main).msef -tearoff 0] - set data_menu(Set,File) [menu $data_menu(main).mstf -tearoff 0] - set data_menu(File,File) [menu $data_menu(main).mfif -tearoff 0] - set data_menu(Anything,File) [menu $data_menu(main).mspf -tearoff 0] - set data_menu(Text,File) [menu $data_menu(main).mtef -tearoff 0] - set data_menu(TimeSet,File) [menu $data_menu(main).mtif -tearoff 0] - set data_menu(NameBlock,File) [menu $data_menu(main).mnbf -tearoff 0] - - set data_menu(Code,Functions) [menu $data_menu(main).mcofu -tearoff 0] - set data_menu(Complex,Functions) [menu $data_menu(main).mcxfu -tearoff 0] - set data_menu(Date,Functions) [menu $data_menu(main).mdafu -tearoff 0] - set data_menu(Matrix,Functions) [menu $data_menu(main).mmafu -tearoff 0] - set data_menu(VMatrix,Functions) [menu $data_menu(main).mvmfu -tearoff 0] - set data_menu(Polyn,Functions) [menu $data_menu(main).mpofu -tearoff 0] - set data_menu(Ratio,Functions) [menu $data_menu(main).mrafu -tearoff 0] - set data_menu(Real,Functions) [menu $data_menu(main).mrefu -tearoff 0] - set data_menu(Serie,Functions) [menu $data_menu(main).msefu -tearoff 0] - set data_menu(Set,Functions) [menu $data_menu(main).mstfu -tearoff 0] - set data_menu(File,Functions) [menu $data_menu(main).mfifu -tearoff 0] - set data_menu(Anything,Functions) [menu $data_menu(main).mspfu -tearoff 0] - set data_menu(Text,Functions) [menu $data_menu(main).mtefu -tearoff 0] - set data_menu(TimeSet,Functions) [menu $data_menu(main).mtifu -tearoff 0] - set data_menu(NameBlock,Functions) [menu $data_menu(main).mnbfu -tearoff 0] - - set data_menu(Matrix,Table) [menu $data_menu(main).mmat -tearoff 0] - set data_menu(Matrix,Export) [menu $data_menu(main).mmae -tearoff 0] - set data_menu(Matrix,Draw) [menu $data_menu(main).mmac -tearoff 0] - set data_menu(Matrix,Export,BDT) [menu $data_menu(main).mmaebdt -tearoff 0] - set data_menu(Serie,DrawAutocor) [menu $data_menu(main).mseda -tearoff 0] - set data_menu(Serie,TableAutocor) [menu $data_menu(main).mseta -tearoff 0] - set data_menu(Set,Table) [menu $data_menu(main).mstt -tearoff 0] - set data_menu(Set,Table2) [menu $data_menu(main).mstt2 -tearoff 0] - set data_menu(Set,Draw) [menu $data_menu(main).mstd -tearoff 0] - set data_menu(Set,Draw,Special) [menu $data_menu(main).mstds -tearoff 0] - set data_menu(Set,Draw,Special,M) [menu $data_menu(main).mstdsm -tearoff 0] - set data_menu(File,View) [menu $data_menu(main).mfiv -tearoff 0] - set data_menu(File,Decompile) [menu $data_menu(main).mfid -tearoff 0] - set data_menu(TimeSet,View) [menu $data_menu(main).mtiv -tearoff 0] - #$ht_vars bind Entry +[$ht_vars bind Entry ] - - # composes the menus for each one of the trees, depending the node - # that is selected - $ht_vars bind all +[list ::TolInspector::PostVariable %X %Y] - $ht_funcs bind all +[list ::TolInspector::PostFunction %X %Y] - $ht_tree bind all +[list ::TolInspector::PostTree %X %Y] -} - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::GetWeight { pane } { -# -# PURPOSE: Set data(geometry,$pane) to the value of the current geometry -# of the pane -# -# PARAMETERS: -# pane -> string with a value "left" or "right" for each one of panels -# -#///////////////////////////////////////////////////////////////////////////// - variable widgets - variable data - - if {[winfo exists $widgets(panes,$pane)]} { - set data(geometry,$pane) [winfo width $widgets(panes,$pane)] - } - set data(geometry,$pane) -} - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::Destroy { } { -# -# PURPOSE: Destroys the three trees of TolInspector and array with full -# content & description of items -# -#///////////////////////////////////////////////////////////////////////////// - variable blt_tree - variable blt_vartree - variable blt_functree - variable item_data - - ::blt::tree destroy $blt_tree - ::blt::tree destroy $blt_vartree - ::blt::tree destroy $blt_functree - unset item_data -} - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::OneLine { str } { -# -# PURPOSE: Gives a string with carriage returns \n and return this string -# until the first carriage return that appears after a word, -# replacing the rest by ... if some word existed after that carriage -# return -# Examples: the str "a\n b c" returns "a..." -# "\n \n a\n b" returns "a..." -# "\n \n a\n" returns "a" -# PARAMETERS: -# str -> string with \n -# -#///////////////////////////////////////////////////////////////////////////// - set str [string trim $str] - set lnidx [string first "\n" $str] - if { $lnidx != -1 } { - if { [incr lnidx -1] > 0 } { - return "[string range $str 0 $lnidx]..." - } else { - return "..." - } - } - set str -} - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::TrimContent { grammar content } { -#///////////////////////////////////////////////////////////////////////////// - if { [string equal "Real" $grammar] } { - return [::TolConsole::Format $content] - } else { - if { [string equal \"\n\" $content] } { - set content {"\n"} - } - return [OneLine $content] - set content [string trim $content] - set lnidx [string first "\n" $content] - if { $lnidx != -1 } { - if { [incr lnidx -1] > 0 } { - return "[string range $content 0 $lnidx]..." - } else { - return "..." - } - } - set content - } -} - -#///////////////////////////////////////////////////////////////////////////// - proc ::TolInspector::_InsertChild { args } { -# -# PURPOSE: este proc es para ancapsular desc en una lista -# -#///////////////////////////////////////////////////////////////////////////// - eval InsertChild [lrange $args 0 3] [list [list [lindex $args 4]]] [lrange $args 5 end] -} - -#///////////////////////////////////////////////////////////////////////////// - proc ::TolInspector::InsertChild { args } { -# -# PURPOSE: Inserts a node in the corresponding treeview of the right panel. -# -# PARAMETERS: -# args[0] -> grammar -# args[1] -> name -# args[2] -> content -# args[3] -> path -# args[4] -> desc -# Si grammar == "Code" -# args[5] -> ¿es una variable? -# Si grammar == "Set" || "NameBlock" -# args[5] -> indexes of the set -# args[6] -> is file? -# args[7] -> has subset? -# args[8] -> subtype -# args[end] -> "Reference {reference}" end > 4 -# -#///////////////////////////////////////////////////////////////////////////// - variable ht_vars - variable blt_vartree - variable ht_funcs - variable blt_functree - variable gra_parent - - #puts "InsertChild: args=$args [info level 1]" - set grammar [lindex $args 0] - set name [ lindex $args 1 ] - set content [lindex $args 2] - set path [lindex $args 3] - set desc [lindex [lindex $args 4] 0] - - - if {[llength [lindex $args end]] >= 2} { - #set ref [list [lindex [lindex $args end] 0] [lrange [lindex $args end] 1 end]] - set ref [concat [lindex [lindex $args end] 0] [lrange [lindex $args end] 1 end]] - } else { - set ref "" - } - #puts "InsertChild: ref=$ref" - switch $grammar { - Code { - set isvar [lindex $args 5] - if { [string equal $isvar "1"] } { - Insert_HTItem $ht_vars $blt_vartree $grammar $name $content $path $desc $ref - } else { - Insert_HTItem $ht_funcs $blt_functree $grammar $name $content $path $desc $ref - } - } - NameBlock - - Set { - #puts "HTItem, ref = '$ref' '$args'" - # args[5] is the index of the set object - # args[6] is the flag file - # args[8] is the subtype - Insert_HTItem $ht_vars $blt_vartree $grammar $name $content $path $desc \ - [lindex $args 5] [lindex $args 6] [lindex $args 8] $ref - } - default { - Insert_HTItem $ht_vars $blt_vartree $grammar $name $content $path $desc $ref - } - } -} - -# si grammar == "Set" -# args[0] -> indexes -# args[1] -> ¿is a file? -# args[2] -> subtype - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::Insert_HTItem {ht tree grammar name content path desc args} { -#///////////////////////////////////////////////////////////////////////////// - variable ht_tree - variable tolset - variable tolindex - variable iterSet - variable knownReference - variable node_prefix - variable item_data - variable item_id - variable gra_parent - - #upvar \#0 ::TolTk::Images Images - - #puts "ENTER: ::TolInspector::Insert_HTItem" - if { $knownReference eq "" } { - set objRef $iterSet - lappend objRef $item_id - } else { - #puts "knownReference = $knownReference" - set objRef $knownReference - } - - #puts "\tobjRef = $objRef" - if { $gra_parent eq "NameBlock" } { - array set info_member [ FilterNameBlockMember $name ] - if { !$info_member(-show) } { - incr item_id - return - } - set fcolor $info_member(-fcolor) - } else { - set fcolor "black" - } - - set brief_cont [TrimContent $grammar $content] - set brief_desc [TrimContent DONTCARE $desc] - #puts "Insert_HTItem: args=$args" - if {[llength [lindex $args end]] >= 2} { - set ref_value [lindex [lindex $args end] 1] - } elseif {[regexp -- "console" $node_prefix]} { - set ref_value [list Console] - eval lappend ref_value $tolindex $item_id - } else { - set ref_value "" - } - - #puts "Insert_HTItem: ref_value=$ref_value tolindex=$tolindex item_id=$item_id node_prefix=$node_prefix" - #puts "\ttolset=$tolset" - set data [list Index $item_id \ - Content $brief_cont \ - Path $path \ - Description $brief_desc \ - Reference $ref_value] - - if {$grammar eq "Set" || $grammar eq "NameBlock"} { - if {[string length $tolset] || [regexp "console" $node_prefix]} { - # OJO: si tolset == "" no implica que no estemos en un Set - # por ejemplo un Set de la consola. - set item [GetItemName $node_prefix [lindex $args 0]] - #Tolcon_Trace "InsertHTItem. item(if): $item" - } else { - switch [lindex [$ht_tree get -full anchor] end] { - root-files { - set item file$item_id - } - root-console { - set item console$item_id - } - root-pool { - set item pool$item_id - } - default { - set item item$item_id - } - } - } - # aqui hay que pedir el bitmap en funcion del subtype: args[2] - if {$grammar eq "Set"} { - #puts "*******Set $objRef *******" - set icon_grammar [SubTypeImage [lindex $args 2]] - set data [lreplace $data 9 9 $objRef] - } else { - #(pgea) se reemplaza el valor de la referencia en data - set data [lreplace $data 9 9 $objRef] - #(pgea) se utiliza la informacon de instancia - #puts "Tol_ClassOfFromReference $objRef" - set classOf [Tol_ClassOfFromReference $objRef] - #puts "Tol_InstanceContentFromReference $objRef" - set insCont [Tol_InstanceContentFromReference $objRef] - if {$insCont ne ""} { - set data [lreplace $data 3 3 [TrimContent $grammar $insCont]] - } elseif {$classOf ne ""} { - set data [lreplace $data 3 3 $classOf] - } - set objAddress [ tol::info address $objRef ] - set icon_grammar [ ::ImageManager::getIconForInstance $objAddress ] - } - } elseif { $grammar eq "Anything" } { - set item "item$item_id" - set anyType [ tol::info anything $objRef ] - set icon_grammar [ ::Bitmap::get $anyType ] - } else { - set item "item$item_id" - set icon_grammar [ ::Bitmap::get $grammar ] - } - set idnew [$tree insert 0 -label $item] - set label [OneLine $name] - if {$label eq ""} { - if {[set label $brief_desc] eq ""} { - set label " " - } - } - $ht entry configure $idnew -label $label \ - -icons [list $icon_grammar $icon_grammar] -data $data \ - -foreground $fcolor - set item_data($item_id) [list $content $desc $grammar] - incr item_id -} - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::ClearHiertables { } { -# -# PURPOSE: -# -#///////////////////////////////////////////////////////////////////////////// - variable w_tabset - variable ht_vars - variable ht_funcs - variable item_data - variable OnSelectItem - - $ht_vars entry delete root 0 end - $ht_funcs entry delete root 0 end - $ht_vars column configure Index -hide no - $ht_funcs column configure Index -hide no - catch { - unset item_data - } - $w_tabset tab configure Variables -text [mc Variables] -state normal - $w_tabset tab configure Functions -state normal - - if { [string length $OnSelectItem] } { - $OnSelectItem - } -} - -# este proc debe pasar a ser un getContainerReference -# -proc ::TolInspector::getPackageReference { treePath } { - variable ht_tree - - #puts "::TolInspector::getPackageReference $treePath" - catch { - set typeContainer "NameBlock" - set order [ lindex [ split [ lindex $treePath 2 ] "-" ] end ] - incr order -1 - #puts "path,2 = [ lindex $treePath 2 ]" - #puts "order = $order" - set idx [lindex [ $ht_tree entry children "root-packages"] $order] - set nameContainer [ $ht_tree entry cget $idx -label ] - #puts "en root-package:" - #puts "\torder=$order" - #puts "\tidx=$idx" - #puts "\tnameContainer=$nameContainer" - set container [ list $typeContainer $nameContainer ] - if { [ llength $treePath ] > 3 } { - foreach c [ lrange $treePath 3 end-1 ] { - set orderItem [ lindex [ split $c "-" ] end ] - lappend container $orderItem - } - set tolindex [ lindex [ split [ lindex $treePath end ] "-" ] end ] - } else { - set tolindex [ list ] - } - } msg - #puts "::TolInspector::getPackageReference: $msg" - #puts "::TolInspector::getPackageReference: [ list $container $tolindex ]" - return [ list $container $tolindex ] -} - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::OpenObject { index } { -# -# PURPOSE: Script called each time a node in ht_tree (left treeview) is -# opened. -# -# PARAMETERS: -# index : The id of the node opened -# -#///////////////////////////////////////////////////////////////////////////// - variable tolset - variable tolindex - variable iterSet - variable at_set - variable node_prefix - variable ht_tree - variable data - - #puts "OpenObject: index=$index" - set path [$ht_tree get -full $index] - #puts "path = $path" - if { $index } { - set parent1 [lindex $path 1] - if { [set ispackage [string equal $parent1 "root-packages"]] || - [set isfile [string equal $parent1 "root-files"]] || - [set isconsole [string equal $parent1 "root-console"]] || - [string equal $parent1 "root-pool"] } { - set lpath [llength $path] - #puts "lpath = $lpath" - if { $lpath == 2 } { - if { $ispackage } { - InsertPackages - } elseif { $isfile } { - InsertFiles - } elseif { $isconsole } { - InsertConsoleObj - } else { - InsertPoolObj - } - } else { - #puts "OpenObject: path = $path" - set leaf [lindex $path end] - set leaf_info [split $leaf "-"] - set node_prefix [lindex $leaf_info 0] - set _tolset $tolset - if { $parent1 eq "root-packages" } { - foreach {tolset tolindex} [ getPackageReference $path ] break - } elseif { [string equal $parent1 "root-pool"] } { - #Tolcon_Trace "OpenObject. tolset=$tolset" - set tolset $data(pool,reference,[lindex $leaf_info 0]) - #puts "OpenObject: Spool: tolset=$tolset, leaf_info=$leaf_info" - if { $lpath == 3 } { - set tolindex [lrange $tolset 1 end] - set tolset [lindex $tolset 0] - } else { - set tolindex [lrange $leaf_info 1 end] - if {[lindex $tolset 0] eq "Console"} { - set tolset [lindex $tolset 0] - } else { - set tolset [lrange $tolset 0 1] - } - #set tolindex [lrange $tolset 1 end] - #set tolset [lindex $tolset 0] - #lappend tolindex [lindex $leaf_info end] - } - #Tolcon_Trace "OpenObject. tolset=$tolset" - } elseif {[regexp -- "console(.+)" $node_prefix --> idx_con]} { - set tolset "Console" - #puts "OpenObject: Console: leaf_info = $leaf_info" - if {[llength $leaf_info] == 1} { - set tolindex $idx_con - } else { - #set tolindex [list $idx_con [lrange $leaf_info 1 end]] - set tolindex [lrange $leaf_info 1 end] - } - } else { - set idx [$ht_tree find -name $node_prefix] - array set aryData [$ht_tree entry cget $idx -data] - set tolset [list File $aryData(FileName)] - #set tolset [$ht_tree entry cget [$ht_tree find -name $node_prefix] -label] - if { $lpath == 3 } { - set tolindex "" - } else { - set tolindex [lrange $leaf_info 1 end] - } - } - Busy - set at_set $index - set iterSet [eval list $tolset $tolindex] - variable gra_parent [ GetParentGrammar $iterSet ] - ::tol::forallchild $iterSet ::TolInspector::InsertSubset - set tolset $_tolset - NotBusy - } - } - } -} - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::InsertPackages {} { -# -# PURPOSE: Inserts a node in ht_tree (left ::blt::treeview) for each TOL -# packages -# -#///////////////////////////////////////////////////////////////////////////// - variable ht_tree - #upvar \#0 ::TolTk::Images Images - - set order 1 - foreach pkg [::tol::info packages] { - # takes an icon with the same name that the grammar - set img [ ::Bitmap::get NameBlock ] - $ht_tree insert -at "root-packages" end package-$order -label $pkg\ - -icons [list $img $img] -button yes - incr order - } -} - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::InsertGrammars {} { -# -# PURPOSE: Inserts a node in ht_tree (left ::blt::treeview) for each TOL -# grammar -# -#///////////////////////////////////////////////////////////////////////////// - variable ht_tree - #upvar \#0 ::TolTk::Images Images - - set id 1 - foreach g [::tol::info grammars] { - # takes an icon with the same name that the grammar - set img [::Bitmap::get $g] - $ht_tree insert -at "root-grammars" end grammar-$id -label $g\ - -icons [list $img $img] - incr id - } -} - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::InsertFiles { } { -# -# PURPOSE: Inserts a node in ht_tree (left treeview) for each Included file -# -#///////////////////////////////////////////////////////////////////////////// - variable ht_tree - variable blt_tree - - set index 1 - #set img [::Bitmap::get "File"] - foreach f [lreverse [::tol::info included]] { - set finfo [::tol::info included $f] - set button [lindex $finfo 3] - set subtype [lindex $finfo 4] - # tomar la imagen en funcion del subtype - set img [SubTypeImage $subtype] - set tag_file "file$index" - set blt_idx [$blt_tree insert "root-files" \ - -label $tag_file -tags $tag_file] - # Tail del fichero. Podría hacerse configurable por el usuario - set label [file tail $f] - $ht_tree entry configure $blt_idx -label $label\ - -icons [list $img $img] -button $button -data [list "FileName" $f] - incr index - } -} - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::InsertConsoleObj { } { -# -# PURPOSE: Inserts a node in ht_tree (left treeview) for each Console object -# -#///////////////////////////////////////////////////////////////////////////// - variable ht_tree - variable has_button 0 - - set index 1 - foreach co [::tol::console stack list] { - set grammar [lindex $co 0] - if {$grammar eq "Set" || $grammar eq "NameBlock"} { - # SUBTYPE: icono en funcion de [lindex $co 7] - if {$grammar eq "Set"} { - set icon [SubTypeImage [lindex $co 7]] - } else { - set objRef [ list "Console" $index ] - set objAddress [ tol::info address $objRef ] - set icon [ ::ImageManager::getIconForInstance $objAddress ] - } - set name [lindex $co 1] - #tol::forallchild $name HasSubset - set has_button [lindex $co 6] - if {$name eq ""} { - if {[set name [TrimContent DONTCARE [lindex $co 4]]] eq ""} { - set name " " - } - } - $ht_tree insert -at root-console end "console$index" -label $name \ - -icons [list $icon $icon] -button $has_button -data [list "FileName" $index] - } - incr index - } -} - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::InsertPoolObj { } { -# -# PURPOSE: Inserts a node in ht_tree (left treeview) for each object in Spool -# -#///////////////////////////////////////////////////////////////////////////// - variable data - variable ht_tree - array unset data pool,reference,* - set index 1 - - foreach _obj $data(pool,objects) { - #Tolcon_Trace "InsertPoolObj. _obj=$_obj" - array set obj $_obj - if { [string equal $obj(grammar) "Set"] || [string equal $obj(grammar) "NameBlock"] } { - #Si la referencia del objeto tiene espacios en la ruta, el - # llength me daría > 1, por eso añado la 2ª parte de la condicion - if { ([llength $obj(reference)] > 1) && \ - ![string equal $obj(reference) $obj(objName)]} { - set infoObj [::tol::info variable $obj(reference)] - } else { - if {[catch { set infoObj [concat [list "Set" $obj(reference)] \ - [::tol::info included $obj(reference)]] }]} { - set infoObj [concat [list "Set" $obj(reference)] \ - [::tol::info variable "Set" $obj(reference)]] - } else { - # Insertamos el 1 de isFile - set infoObj [linsert $infoObj 5 1] - } - } - #Tolcon_Trace "infoObj=$infoObj" - if {[set name [file tail [lindex $infoObj 1]]] eq ""} { - if {[set name [TrimContent DONTCARE [lindex $infoObj 4]]] eq ""} { - set name " " - } - } - set has_button [lindex $infoObj 6] - #set icon [SubTypeImage [lindex $infoObj 7]] - if {$obj(grammar) eq "Set"} { - set icon [SubTypeImage [lindex $infoObj 7]] - } else { - #puts "en pool = $obj(reference)" - set objAddress [ tol::info address $objRef ] - set icon [ ::ImageManager::getIconForInstance $objAddress ] - } - - $ht_tree insert -at root-pool end "pool$index" -label $name \ - -icon [list $icon $icon] -button $has_button - #Tolcon_Trace "InsertPoolObj. name=$name" - if { ([llength $obj(reference)] > 1) && \ - [string equal $obj(reference) $obj(objName)]} { - set obj(reference) [list $obj(reference)] - } - set data(pool,reference,pool$index) $obj(reference) - } - incr index - } -} - -proc ::TolInspector::FilterNameBlockMember { name } { - set st_reg [ regexp {(.+::)?(_)?(\.)?(.*)} $name => p1 p2 p3 p4] - if { !$st_reg } { - list -show 1 -fcolor "black" -name $name - } elseif { $p2 eq "_" } { - if { $p3 eq "." } { - if { [string match {autodoc.member.*} $p4] } { - # es un elemento de autodocumentacion y no se muestra - list -show 0 - } { - # es un miembro de solo lectura - list -show 1 -fcolor "gray50" -name "_.$p4" - } - } else { - # es un miembro oculto, - set showPrivate [ Tol_GetViewPrivateMembers ] - list -show $showPrivate -fcolor "gray75" -name "_$p4" - } - } else { - list -show 1 -fcolor "black" -name $p4 - } -} - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::InsertSubset { args } { -# -# PURPOSE: Inserts a node in ht_tree (left treeview) for each child of a Set -# -# PARAMETERS: -# args[0] -> grammar -# args[1] -> name -# args[2] -> content -# args[3] -> path -# args[4] -> desc -# Si grammar == "Set" -# args[5] -> indexes of the set -# args[6] -> is file? -# args[7] -> has subset? -# args[8] -> subtype -# -#///////////////////////////////////////////////////////////////////////////// - variable ht_tree - variable at_set - variable tolset - variable iterSet - variable node_prefix - variable has_button 0 - variable blt_tree - variable gra_parent - catch { - #puts "InsertSubset, args=$args" - set grammar [lindex $args 0] - if {$grammar eq "Set" || $grammar eq "NameBlock"} { - #puts "InsertSubset, args=$args" - if { $gra_parent eq "NameBlock" } { - array set info_member [ FilterNameBlockMember [ lindex $args 1 ] ] - if { !$info_member(-show) } { - return - } - set name $info_member(-name) - set fcolor $info_member(-fcolor) - } else { - set name [ lindex $args 1 ] - set fcolor "black" - } - set content [lindex $args 2] - # idx es el indice completo desde el Set root - set idx [lindex $args 5] - set isfile [lindex $args 6] - set has_button [lindex $args 7] - set subtype [lindex $args 8] - #tol::forallchild $tolset $idx HasSubset - if {$grammar eq "Set"} { - set icon [SubTypeImage $subtype] - } else { - set objRef $iterSet - lappend objRef [ lindex $idx end ] - set objAddress [ tol::info address $objRef ] - set icon [ ::ImageManager::getIconForInstance $objAddress ] - } - # Tail por si es un fichero. Podría hacerse configurable por el usuario - set label [file tail $name] - #puts [list InsertSubset, idx {lindex $args 5} = $idx] - set idnew [ $blt_tree insert $at_set \ - -label [ GetItemName $node_prefix $idx ] ] - - #puts "InsertSubset, node_prefix = $node_prefix" - #puts "InsertSubset, idnew = $idnew" - #puts "InsertSubset, -label = [GetItemName $node_prefix $idx]" - - if {$label eq ""} { - if {[set label [TrimContent DONTCARE [lindex $args 4]]] eq ""} { - set label " " - } - } - $ht_tree entry configure $idnew -label $label -button $has_button \ - -icons [list $icon $icon] -foreground $fcolor - } -} msg -#puts "InsertSubSet: $msg" -} - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::ClearConsoleObj { } { -#///////////////////////////////////////////////////////////////////////////// - variable ht_tree - variable data - - set idx_con [$ht_tree index root-console] - $ht_tree entry delete $idx_con 0 end - - #Quitamos del spool todos los objetos que provengan de la consola - foreach _obj $data(pool,objects) { - array set obj $_obj - if {[string equal $obj(origin) "root-console"]} { - set idx [lsearch $data(pool,objects) $_obj] - set data(pool,objects) [lreplace $data(pool,objects) $idx $idx] - } - } - UpdatePoolObj - #Finalmente limpiamos el stack de la consola de tol - ::tol::console stack release -} - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::ClearConsoleObjSel {ht} { -#///////////////////////////////////////////////////////////////////////////// - variable vars_selected - variable data - - foreach var $vars_selected { - set name [$ht entry cget $var -label] - #puts "name=$name" - #Quitamos del spool todos los objetos que provengan de la consola - foreach _obj $data(pool,objects) { - array set obj $_obj - #puts "_obj=$_obj" - if {[string equal $obj(origin) "root-console"] && [string equal $obj(objName) $name]} { - set idx [lsearch $data(pool,objects) $_obj] - set data(pool,objects) [lreplace $data(pool,objects) $idx $idx] - } - } - UpdatePoolObj - #Finalmente quitamos el objeto de la consola de tol - ::tol::console stack release $name - } - UpdateConsoleObj -} - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::UpdateFileRoot { } { -#///////////////////////////////////////////////////////////////////////////// - variable ht_tree - set open 0 - set idx_file [$ht_tree index root-files] - if { [$ht_tree entry isopen $idx_file] } { - $ht_tree close $idx_file - set open 1 - } - if { [$ht_tree index focus] == $idx_file } { - SelectObject - } - if $open { - $ht_tree open $idx_file - } -} - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::UpdateConsoleObj { } { -#///////////////////////////////////////////////////////////////////////////// - variable ht_tree - - set idx_con [$ht_tree index root-console] - if { [$ht_tree entry isopen $idx_con] } { - $ht_tree close $idx_con - } - $ht_tree selection anchor root-console - $ht_tree selection mark root-console - #Tolcon_Trace "Abierto el nodo root-console" - if { [$ht_tree index focus] == $idx_con } { - SelectObject - } -} - - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::UpdatePoolObj { } { -#///////////////////////////////////////////////////////////////////////////// - variable ht_tree - - set idx_pool [$ht_tree index root-pool] - if { [$ht_tree entry isopen $idx_pool] } { - $ht_tree close $idx_pool - } - if { [$ht_tree index focus] == $idx_pool } { - SelectObject - } -} - - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::SelectObject { } { -# -# PURPOSE: Script called each time a node in ht_tree (left treeview) is -# selected. -# -#///////////////////////////////////////////////////////////////////////////// - - #Tolcon_Trace "LLAMADA A SELECTOBJECT" - variable w_tabset - variable ht_tree - #variable set_type "" - variable tolset - variable tolindex - #variable closing - variable node_prefix "" - variable data - variable knownReference "" - - set index [$ht_tree index anchor] - - if { ![string length $index] } { - ClearHiertables - return - } - ClearHiertables - - set path [ $ht_tree get -full $index ] - set tolset "" - if { $index } { - #puts "SelectObject index = $index" - #puts "SelectObject: full = $path" - set info_node [split [lindex $path end] "-"] ;# ojo si el path tiene - - set node_type [lindex $info_node 0] - set node_name [lindex $info_node 1] - #puts "SelectObject: info_node = $info_node" - } else { - set node_type root - set node_name root - } - - Busy - #puts "SelectObject: node_type = $node_type, node_name = $node_name" - switch -regexp $node_type { - root { - switch $node_name { - root - - grammars { - ClearHiertables - #$w_tabset tab configure Variables -state disabled - #$w_tabset tab configure Functions -state disabled - } - package { - puts "implementa el llenado del panel derecho" - } - files { - SelectFileRoot - } - console { - SelectConsoleRoot - } - pool { - SelectPoolRoot - } - } - } - grammar { - SelectGrammar - } - default { - set node_prefix $node_type - #puts "SelectObject: node_prefix = $node_prefix" - if { $node_type eq "package" } { - foreach {tolset tolindex} [ getPackageReference $path ] break - } elseif {[regexp -- "pool" $node_type]} { - set tolset $data(pool,reference,[lindex $node_type 0]) - #puts "SelectObject: Spool: tolset=$tolset, info_node=$info_node" - if { [llength $info_node] == 1 } { - set tolindex [lrange $tolset 1 end] - set tolset [lindex $tolset 0] - } else { - #set tolindex [lrange $tolset 1 end] - #set tolset [lindex $tolset 0] - #lappend tolindex [lindex $info_node end] - set tolindex [lrange $info_node 1 end] - if {[lindex $tolset 0] eq "Console"} { - set tolset [lindex $tolset 0] - } else { - set tolset [lrange $tolset 0 1] - } - } - } elseif {[regexp -- "console(.+)" $node_type --> idx_con]} { - #puts "SelectObject: Console: tolset=$tolset info_node=$info_node idx_con=$idx_con" - set tolset "Console" - #set idx [$ht_tree find -name $node_type] - #array set aryData [$ht_tree entry cget $idx -data] - #set tolindex [eval list $aryData(FileName) [lrange $info_node 1 end]] - if {[llength $info_node] == 1} { - set tolindex $idx_con - } else { - set tolindex [lrange $info_node 1 end] - #set tolindex [concat [list $idx_con] $tolindex] - } - } else { - set idx [$ht_tree find -name $node_type] - array set aryData [$ht_tree entry cget $idx -data] - #puts "SelectObject: FileName=$aryData(FileName) info_node=$info_node" - set tolset [list File $aryData(FileName)] - set tolindex [lrange $info_node 1 end] - #set tolindex [lrange $info_node 2 end] - } - #puts "SelectObject end: tolset=$tolset, tolindex=$tolindex" - SelectSet - } - } - NotBusy -} - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::SelectFileRoot { } { -# -# PURPOSE: Script called each time 'Included Files' node in ht_tree is -# selected. Gets information about each node that must be in -# included files, and inserts it in the right treeview. -# -#///////////////////////////////////////////////////////////////////////////// - variable item_id 1 - variable w_tabset - variable knownReference "" - - ClearHiertables - $w_tabset tab configure Variables -text [mc Files] - # $w_tabset tab configure Functions -state disabled - $w_tabset select 0 - foreach f [lreverse [::tol::info included]] { - # this catch is needed because info include could return files not - # realy included. - if { [ catch { ::tol::info included $f } fi ] } continue - # tener en cuenta el subtype cuando lo retorne - set knownReference [ list "File" $f ] - InsertChild Set $f \ - [lindex $fi 0] [lindex $fi 1] [list [lindex $fi 2]] $item_id 1 [lindex $fi 3] [lindex $fi 4] - } -} - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::SelectConsoleRoot { } { -# -# PURPOSE: Script called each time 'Console Objects' node in ht_tree is -# selected. Gets information about each node that must be in console, -# and inserts it in the right treeview. -# -#///////////////////////////////////////////////////////////////////////////// - variable w_tabset - variable ht_vars - variable ht_funcs - variable item_id 1 - variable iterSet "Console" - variable knownReference "" - - ClearHiertables -#(pgea) se quita la linea que oculta la columna del indice y que -#(pgea) el procedimimento anterior ClearHiertables muestra -# $ht_vars column configure Index -hide yes -# $w_tabset tab configure Functions -state disabled - - foreach co [::tol::console stack list] { - #puts "SelectConsoleRoot: co = $co" - set gra [lindex $co 0] - set name [lindex $co 1] - set cont [lindex $co 2] - set path [lindex $co 3] - set desc [lindex $co 4] - set knownReference [ list Console $item_id ] - switch [lindex $co 0 ] { - Code { - InsertChild $gra $name $cont $path [list $desc] 0 - } - NameBlock - - Set { - #puts "switch: SelectConsoleRoot $gra" - InsertChild $gra $name $cont $path [list $desc] \ - $item_id [lindex $co 5] [lindex $co 6] [lindex $co 7] \ - [list Reference [list "Console" $item_id]] - } - default { - InsertChild $gra $name $cont $path [list $desc] \ - [list Reference [list "Console" $item_id]] - } - } - } - set knownReference "" -} - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::SelectPoolRoot { } { -# -# PURPOSE: Script called each time 'Spool Objects' node in ht_tree is -# selected. Gets information about each node that must be in pool, -# and inserts it in the right treeview. -# -#///////////////////////////////////////////////////////////////////////////// - variable w_tabset - variable ht_vars - variable data - variable item_id 1 - variable knownReference "" - - ClearHiertables - $ht_vars column configure Index -hide yes - - array unset data pool,variables,* - # Para cada uno de los objetos que debe haber en el spool - # busco la información del nodo y lo inserto en el treeview de la derecha - foreach _obj $data(pool,objects) { - array set obj $_obj - #Si la referencia del objeto tiene espacios en la ruta, el - # llength me daría > 1, por eso añado la 2ª parte de la condicion - #puts "SelectPoolRoot: obj(grammar)=$obj(grammar) obj(objName)=$obj(objName) obj(reference)=$obj(reference)" - if { ([llength $obj(reference)] > 1) && ![string equal $obj(reference) $obj(objName)]} { - if {$obj(grammar) eq "Code"} { - set infoObj [concat [list $obj(grammar) $obj(objName)] \ - [::tol::info function $obj(reference)]] - } else { - set infoObj [::tol::info variable $obj(reference)] - } - #Tolcon_Trace "tol info (var|function) reference" - } else { - if {[catch { set infoObj [concat [list "Set" $obj(reference)] \ - [::tol::info included $obj(reference)]] }]} { - if {$obj(grammar) eq "Code"} { - set infoObj [concat [list $obj(grammar) $obj(reference)] \ - [::tol::info function $obj(graApply) $obj(reference)]] - } else { - #set infoObj [concat [list $obj(grammar) $obj(reference)] \ - # [::tol::info variable $obj(grammar) $obj(reference)]] - set infoObj [::tol::info variable [list $obj(grammar) $obj(reference)]] - } - #Tolcon_Trace "tol info (var|function) Grammar nameGlobal" - } else { - # Insertamos el 1 de isFile - set infoObj [linsert $infoObj 5 1] - #Tolcon_Trace "tol info included" - } - } - #Tolcon_Trace "INFOOBJ: $infoObj" - set gra [lindex $infoObj 0] - set name [lindex $infoObj 1] - set cont [lindex $infoObj 2] - set path [lindex $infoObj 3] - set desc [lindex $infoObj 4] - set data(pool,variables,$item_id) $obj(reference) - - switch $gra { - Code { - InsertChild $gra $name $cont $path [list $desc] 0 "Reference $obj(reference)" - } - Set - - NameBlock { - set knownReference $obj(reference) - InsertChild $gra $name $cont $path [list $desc] \ - $item_id [lindex $infoObj 5] [lindex $infoObj 6] [lindex $infoObj 7] "Reference $obj(reference)" - set knownReference "" - } - default { - InsertChild $gra $name $cont $path [list $desc] "Reference $obj(reference)" - } - } - } -} - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::SelectGrammar { } { -# -# PURPOSE: Script called each time a Grammar node in ht_tree is selected. Gets -# information about each var and function of this grammar, and -# inserts them in the right treeview. -# -#///////////////////////////////////////////////////////////////////////////// - variable w_tabset - variable ht_tree - variable ht_vars - variable ht_funcs - variable item_id 1 - variable OnSelectItem - variable knownReference - - set knownReference "" - ClearHiertables - $ht_vars column configure Index -hide yes - $ht_funcs column configure Index -hide yes - set grammar [$ht_tree entry cget anchor -label] - if { [string compare $grammar "Anything"] } { - if { [string length $OnSelectItem] } { - $OnSelectItem [::tol::info grammars $grammar] - } - foreach var [::tol::info variables $grammar] { - if {[catch { - set vinfo [::tol::info variables [list $grammar $var]] - } msg]} { - Tol_HciWriter "in ::TolInspector::SelectGrammar : $msg\n" - continue - } - if { [string equal $grammar "Code"] } { - #Tolcon_Trace "Code : -- $vinfo --" - InsertChild $grammar $var [lindex $vinfo 2] [lindex $vinfo 3] [list [lindex $vinfo 4]] 1 - } elseif { $grammar eq "Set" || $grammar eq "NameBlock" } { - #Tolcon_Trace "Set : -- $vinfo --" - set knownReference [ list $grammar $var ] - InsertChild $grammar $var [lindex $vinfo 2] [lindex $vinfo 3] [list [lindex $vinfo 4]] \ - $item_id [lindex $vinfo 5] [lindex $vinfo 6] [lindex $vinfo 7] - } else { - InsertChild $grammar $var [lindex $vinfo 2] [lindex $vinfo 3] [list [lindex $vinfo 4]] $item_id 0 - } - } - } else { -# $w_tabset tab configure Variables -state disabled -# $w_tabset select 1 - } - foreach fun [::tol::info functions $grammar] { - set finfo [::tol::info functions $grammar $fun] - InsertChild Code $fun [lindex $finfo 0] [lindex $finfo 1] [list [lindex $finfo 2]] 0 - } -} - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::SelectSet { } { -# -# PURPOSE: Script called each time a Set node in ht_tree is selected. Gets -# information about each child of this set, and inserts it in the -# right treeview. -# -#///////////////////////////////////////////////////////////////////////////// - variable ht_tree - variable ht_vars - variable ht_funcs - - variable tolset - variable tolindex - variable iterSet - variable var_id 1 - variable fun_id 1 - variable item_id - #variable selecting_set - - # if { $selecting_set } { - #puts "eoooo ..." - # return - # } - ClearHiertables - # set selecting_set 1 - set item_id 1 - - #puts "SelectSet: tolset=$tolset tolindex=$tolindex" - set iterSet [eval list $tolset $tolindex] - variable gra_parent [ GetParentGrammar $iterSet ] - ::tol::forallchild $iterSet ::TolInspector::_InsertChild - # set selecting_set 0 -} - -proc ::TolInspector::GetParentGrammar { set_ref } { - set root [ lindex $set_ref 0 ] - set L [ llength $set_ref ] - if { ( $root eq "File" && $L <= 2 ) } { - set root - } else { - lindex [ tol::info var $set_ref ] 0 - } -} - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::CloseObject { index } { -# -# PURPOSE: Script called each time a node in ht_tree (left treeview) is -# closed. -# -# PARAMETERS: -# index : The id of the node closed -# -#///////////////////////////////////////////////////////////////////////////// - variable ht_tree - #variable closing 1 - set path [$ht_tree get -full $index] - if { $index } { - set parent1 [lindex $path 1] - if { [string equal $parent1 "root-packages"] || - [string equal $parent1 "root-files"] || - [string equal $parent1 "root-console"] || - [string equal $parent1 "root-pool"] } { - $ht_tree entry delete $index 0 end - } - } -} - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::HasSubset { args } { -#///////////////////////////////////////////////////////////////////////////// - if { [string equal [lindex $args 0] "Set"] } { - variable has_button 1 - return 0 - } - return 1 -} - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::OpenVariable { index } { -# -# PURPOSE: ???? -# -# PARAMETERS: -# index -> -# -#///////////////////////////////////////////////////////////////////////////// - variable tolset ;# Name of the current TOL set variable - variable ht_vars ;# ::blt::treeview of variables - variable ht_tree ;# ::blt::treeview left - variable blt_tree ;# ::blt::tree left - variable item_data ;# Array to hold the full content & description of items - - if { ![string length $index] } { - return - } - set node_anchor [lindex [$ht_tree get -full anchor] end] - - set tree_index -1 - #puts "OpenVariable = $item_data([lindex [$ht_vars entry cget $index -data] end])" - if { ![regexp -- "grammar-" $node_anchor] } { - set grammar [lindex $item_data([lindex [$ht_vars entry cget $index -data] end]) 2] - if {$grammar eq "Set" || $grammar eq "NameBlock"} { - $ht_tree open anchor - #puts "full = [$ht_vars get -full $index]" - set local_name [lindex [$ht_vars get -full $index] end] - set idx_anchor [$ht_tree index anchor] - #puts "a buscar $local_name dentro de $idx_anchor" - if {[set tree_index [$blt_tree findchild $idx_anchor $local_name]] == -1} { - foreach idx [$ht_tree entry children anchor] { - if { [string equal $local_name [lindex [$ht_tree get -full $idx] end]] } { - set tree_index $idx - break - } - } - } - } - } - if { $tree_index != -1 } { - update - blt::tv::SetSelectionAnchor $ht_tree $tree_index - set blt::tv::scroll 1 - #$ht_tree selection clearall - #$ht_tree see $tree_index - #$ht_tree focus $tree_index - #$ht_tree selection set $tree_index - #$ht_tree selection anchor $tree_index - #set blt::Hiertable::scroll 1 - } -} - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::SelectItem { ht } { -# -# PURPOSE: Procedure that is executed when the user selects an element of -# the trees of variables orfunctions. -# First it take all the arguments necessary of the node of tree to -# execute the procedure stored in the variable OnSelectItem, and -# later executes it passing those arguments. -# -# PARAMETERS: path of ht_* (::blt::treeview of variables or of functions) -# -#///////////////////////////////////////////////////////////////////////////// - # variable w_text ;# TODO: ???? - variable OnSelectItem ;#Command to invoke on SelectItem in ht_* - variable item_data ;# Array to hold the full content & description of items - - set entry [$ht index anchor] ;# id of entry selected - if { [string length $OnSelectItem] } { - # there are associated command - if { [string length $entry] } { - # almost one entry of ht_* selected - array set aryData [$ht entry cget $entry -data] - set name [$ht entry cget $entry -label] ;# name of item - set itemid $aryData(Index) ;# id of item - set path $aryData(Path) ;# path of file of item - #(pgea) se anyade la propiedad Reference - set objRef $aryData(Reference) ;# info of item - set full_data $item_data($itemid) ;# {value} {desc} {grammar} - set value [lindex $full_data 0] ;# value of item PE: - # Anything Field(Set s, Text nombre) - - if { [string equal \"\n\" $value] } { - # hasn't value - set value {"\n"} - } else { - set value [string trim $value] - } - set desc [string trim [lindex $full_data 1]] - set grammar [lindex $full_data 2] - set icon [lindex [$ht entry cget $entry -icons] 0] - #(pgea) lista de argumentos que recibe ::TolConsole::OnInfo - set args [list $icon $grammar $name $value $path $desc $objRef] - } else { - set args "" - } - eval "$OnSelectItem $args" - } - return -#;# TODO: ???? -# if { [string length $entry] } { -# FillText $ht $entry -# } else { -# $w_text delete 1.0 end -# } -} - -#///////////////////////////////////////////////////////////////////////////// -#(pgea) se usa? -proc ::TolInspector::FillText { ht entry } { -#///////////////////////////////////////////////////////////////////////////// - variable w_text - variable item_data - #upvar #0 ::TolTk::Images Images - - $w_text delete 1.0 end - array set aryData [$ht entry cget $entry -data] - set name [$ht entry cget $entry -label] - set itemid $aryData(Index) - set full_data $item_data($itemid) - - set value [lindex $full_data 0] - if { [string equal \"\n\" $value] } { - set value {"\n"} - } - set desc [string trim [lindex $full_data 1]] - set grammar [lindex $full_data 2] - set icon [lindex [$ht entry cget $entry -icons] 0] - foreach {prop val} [list "Grammar: " $grammar "Name: " $name "Value: " [string trim $value]] { - set idx_start [$w_text index "end -1 chars"] - $w_text insert end $prop - set idx_end [$w_text index "end -1 chars"] - $w_text tag add tagLabel $idx_start $idx_end - if {[string equal $prop "Grammar: "]} { - $w_text image create end -image $icon - $w_text insert end " " - } - $w_text insert end "$val\n" - $w_text tag add tagValue $idx_end [$w_text index "end -1 chars"] - } - $w_text tag configure tagLabel -font fnBold - $w_text tag configure tagValue -wrap none - if { [string length $desc] } { - set idx_start [$w_text index "end -1 chars"] - $w_text insert end "Description\n" - set idx_end [$w_text index "end -1 chars"] - $w_text tag add tagPropLabel $idx_start $idx_end - $w_text insert end $desc - $w_text tag add tagPropValue $idx_end [$w_text index "end -1 chars"] - $w_text tag configure tagPropLabel -font fnBold -underline 1 - $w_text tag configure tagPropValue -wrap word - } -} - -#proc ::TolInspector::GetIndexes { nodeid } { -# variable ht_tree -# # No se utiliza -# # name is prefix-i1-i2-i3-...-in -# -# if { $nodeid } { -# lrange [split [$ht_tree get $nodeid] "-"] 1 end -# } else list -#} - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::GetItemName { prefix idx_list } { -#///////////////////////////////////////////////////////////////////////////// - set node_id $prefix - foreach id $idx_list { - append node_id "-$id" - } - set node_id -} - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::OnBusy { cmd } { -#///////////////////////////////////////////////////////////////////////////// - variable OnBusyCmd $cmd -} - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::Busy { } { -#///////////////////////////////////////////////////////////////////////////// - variable OnBusyCmd - variable ht_tree - variable ht_vars - - $ht_tree configure -cursor watch - $ht_vars configure -cursor watch - if { [string length $OnBusyCmd] } { - eval $OnBusyCmd 1 - } -} - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::NotBusy { } { -#///////////////////////////////////////////////////////////////////////////// - variable OnBusyCmd - variable ht_tree - variable ht_vars - - $ht_tree configure -cursor "" - $ht_vars configure -cursor "" - - if { [string length $OnBusyCmd] } { - eval $OnBusyCmd 0 - } -} - -proc Tol_GetViewPrivateMembers { } { - set viewOpt 0 - catch { - # no funciona - tol::console eval { - Real __getViewPrivateMembers_tmp__ = - TolConfigManager::Config::Various::View::PrivateMembers; - } - set x [ lindex [ tol::info variable { Real __getViewPrivateMembers_tmp__ } ] 2 ] - tol::console stack release __getViewPrivateMembers_tmp__ - set viewOpt [ expr { int( $x ) } ] - - } msg - #puts "Tol_GetViewPrivateMembers: $msg" - return $viewOpt -} - -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" ) - } ] - set info [ tol::info variable {Real __gui_check__} ] - set x [ lindex $info 2 ] - tol::console stack release __gui_check__ - expr { round($x) } -} - -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 Tol_ClassOfFromReference { objReference } { - set addr [ ::tol::info address $objReference ] - return [ Tol_ClassOf $addr ] -} - -proc Tol_StructOf { obj_addr } { - set tolcode [ string map [ list %A $obj_addr ] { - Text { - Anything obj = GetObjectFromAddress( "%A" ); - // WriteLn( "Tol_StructOf " << Grammar( obj ) ); - Text If( Grammar( obj ) == "Set", StructName( obj ), "" ) - } - } ] - return [ lindex [ toltcl::eval $tolcode ] 0 ] -} - -proc Tol_StructOfFromReference { objReference } { - # WATCH!!!! - # when Tol_StructOfFromReference is invoken on {File xxx} xxx is - # decompiled!!!! - if { [ llength $objReference ] == 2 && - [ lindex $objReference 0 ] eq "File" } { - return "" - } - set addr [ ::tol::info address $objReference ] - return [ Tol_StructOf $addr ] -} - -#(pgea) nueva funcion para obtener la informacion de instancia -proc Tol_InstanceInfo { obj_addr } { - tol::console eval [ string map [ list %A $obj_addr ] { - Text __gui_instanceinfo__ = { - Anything __intance__ = GetObjectFromAddress("%A"); - Text If(ObjectExist("Code", "__intance__::_.get.autodoc.info"), - __intance__::_.get.autodoc.info(?), "") - } - } ] - set info [ tol::info variable {Text __gui_instanceinfo__} ] - set x [ string trim [ lindex $info 2 ] \" ] - tol::console stack release __gui_instanceinfo__ - set x -} - -#(pgea) nueva funcion para obtener la informacion de instancia -proc Tol_InstanceInfoFromReference { objReference } { - set addr [ ::tol::info address $objReference ] - return [ Tol_InstanceInfo $addr ] -} - -#(pgea) nueva funcion para obtener el contenido de la instancia -proc Tol_InstanceContent { obj_addr } { - tol::console eval [ string map [ list %A $obj_addr ] { - Text __gui_instancecontent__ = { - Anything __intance__ = GetObjectFromAddress("%A"); - Text If(ObjectExist("Code", "__intance__::_.get.autodoc.content"), - __intance__::_.get.autodoc.content(?), "") - } - } ] - set info [ tol::info variable {Text __gui_instancecontent__} ] - set x [ string trim [ lindex $info 2 ] \" ] - tol::console stack release __gui_instancecontent__ - set x -} - -#(pgea) nueva funcion para obtener el contenido de la instancia -proc Tol_InstanceContentFromReference { objReference } { - set addr [ ::tol::info address $objReference ] - return [ Tol_InstanceContent $addr ] -} - -proc TolGui_GetMenuEntries { selection idx } { - #puts "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 ] - if { [ Tol_ObjIsClassOf $obj_addr "GuiTools::@MenuDesc" ] } { - set class [ Tol_ClassOf $obj_addr ] - 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) ] - } - #puts "$menu_info" - set menu_info -} - -proc TolGui_StoreSetElementsInOZA { object } { - set saveIn [ tk_getSaveFile -defaultextension .oza \ - -parent . -title [ mc "Store OZA" ] \ - -filetypes {{oza {.oza}}} ] - - if { $saveIn ne "" } { - set addr [ tol::info address $object ] - set tolexpr [ string map [ list %a $addr %f $saveIn ] { - Real Ois.Store( GetObjectFromAddress( "%a" ), "%f" ); - } ] - toltcl::eval $tolexpr - } -} - -proc TolGui_StoreSelectionInOZA { selection } { - set saveIn [ tk_getSaveFile -defaultextension .oza \ - -parent . -title [ mc "Store OZA" ] \ - -filetypes {{oza {.oza}}} ] - if { $saveIn ne "" } { - set lst_addr {} - foreach r $selection { - set a [ tol::info address $r ] - lappend lst_addr \"$a\" - } - set set_addr "\[\[ [join $lst_addr ,] \]\]" - set tolexpr [ string map [ list %L $set_addr %f $saveIn ] { - Real { - Set items = EvalSet( %L, Anything( Text addr ) { - Anything GetObjectFromAddress( addr ) - } ); - Real Ois.Store( items, "%f" ) - } - } ] - toltcl::eval $tolexpr - } -} - -proc TolGui_InsertEntriesMatrixChart { mm selection } { - if { ![ llength $selection ] } { - return 0 - } - set lst_addr {} - foreach r $selection { - set a [ tol::info address $r ] - lappend lst_addr \"$a\" - } - set set_addr "\[\[ [join $lst_addr ,] \]\]" - set tolexpr [ string map [ list %L $set_addr ] { - Real { - Set all_mat = EvalSet( %L, Matrix( Text addr ) { - GetObjectFromAddress( addr ) - } ); - Real R = Rows( all_mat[1] ); - Set st = EvalSet( all_mat, Real( Matrix it ) { - Real EQ( R, Rows( it ) ) - } ); - Real BinGroup( "And", st ) - } - } ] - set couldChart [ toltcl::eval $tolexpr ] - if { $couldChart } { - $mm add command -label [ mc "Draw matrix selection (natural)" ] \ - -command [ list TolGui_ChartMatrix $selection ] - } -} - -proc TolGui_ChartMatrix { selection } { - set lst_addr {} - foreach r $selection { - set a [ tol::info address $r ] - lappend lst_addr \"$a\" - } - set set_addr "\[\[ [join $lst_addr ,] \]\]" - set tolexpr [ string map [ list %L $set_addr ] { - Real { - Set all_mat = EvalSet( %L, Matrix( Text addr ) { - GetObjectFromAddress( addr ) - } ); - Set names = Copy( Empty ); - Set For( 1, Card( all_mat ), Real( Real k ) { - Text _n = Name( all_mat[ k ] ); - Text n = If( _n == "", "unamed", _n ); - Set Append( names, If( Columns( all_mat[ k ] ) == 1, [[ n ]], { - Set For( 1, Columns( all_mat[ k ] ), Text( Real k ) { - Text n << "[" << k << "]" - } ) - } ) ); - Real 1 - } ); - Matrix groupMat = BinGroup( "|", all_mat ); - Text TclChartMatrix( groupMat, - SetOfSet ( - @TclArgSt("-title", "Matrix Chart" ), - @TclArgSt("-type" , "2" ), - @TclArgSt("-names", TxtListTcl(names) ) ) ) - } - } ] - toltcl::eval $tolexpr -} - -proc TolGui_InsertEntriesFromMenuManager { targetMenu selection } { - set addrList [ list ] - foreach obj_info $selection { - set tcl_ref [ lindex $obj_info 0 ] - lappend addrList [ ::tol::info address $tcl_ref ] - } - ::MenuManager::insertEntriesForSelection $targetMenu $addrList -} - -proc TolGui_GetObjMenu { obj_addr } { - set try [ catch { - tol::console eval [ string map [ list %A $obj_addr ] { - GuiTools::@MenuDesc __aux_menu__ = GetObjectFromAddress("%A"); - Set __gui_menu_entries__ = __aux_menu__::getMenuEntries(?) - } ] } msg ] - if { $try } { - puts "ERROR TolGui_GetObjMenu : $msg" - set result "" - } else { - set result [ TolObj2TclObj {Set __gui_menu_entries__} ] - } - tol::console stack release __aux_menu__ - tol::console stack release __gui_menu_entries__ - set result -} - -proc TolGui_InvokeMethod { method obj_addr } { - #puts "TolGui_InvokeMethod $method $obj_addr" - set try [ catch { - tol::console eval [ string map [ list %A $obj_addr %M $method ] { - NameBlock __aux_instance__ = GetObjectFromAddress("%A"); - Real __aux_result__ = __aux_instance__::%M(?) - } ] } msg ] - if { $try } { - puts "ERROR TolGui_InvokeMethod : $msg" - } - tol::console stack release __aux_instance__ - tol::console stack release __aux_result__ -} - -proc TclList2SetOfText { lst } { - set result [ list ] - foreach i $lst { - lappend result \"[string map {\" \\\"} $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__ = { - Set aux = EvalSet( %S, NameBlock( Text addr ) { - NameBlock GetObjectFromAddress( addr ) - } ); - Real %C::%F( aux ) - } - } ] } msg ] - if { $try } { - puts "ERROR TolGui_InvokeGroup : $msg" - } - tol::console stack release __aux_result__ -} - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::PostVariable { x y } { -# -# PURPOSE: Composes a popup menu for variables and displays it. Its composed -# depending on the node/s clicked by user. -# -# PARAMETERS: -# x -> x-coordinate where popup menu is drawn -# y -> y-coordinate where popup menu is drawn -# -#///////////////////////////////////////////////////////////////////////////// - variable data_menu - variable vars_selected - variable options_selected - variable ht_vars - variable ht_tree - variable item_data - variable data - - variable tolset - variable tolindex - - #User functions to contextual menu - ::TolInspector::ReadUserFunctions - - array unset options_selected - set all_objects {} - - foreach it [array names data_menu] { - $data_menu($it) delete 0 end - } - set InRootConsole [string equal [lindex [$ht_tree get -full anchor] end] "root-console"] - set InRootPool [string equal [lindex [$ht_tree get -full anchor] end] "root-pool"] - set InRootFiles [string equal [lindex [$ht_tree get -full anchor] end] "root-files"] - #puts "PostVariable: InRootConsole,InRootPool,InRootFiles = $InRootConsole,$InRootPool,$InRootFiles" - set node_act [$ht_vars index current] - if { [string length $node_act] } { - set vars_selected [$ht_vars curselection] - if { [lsearch $vars_selected $node_act] >= 0 } { - foreach var $vars_selected { - array set aryData [$ht_vars entry cget $var -data] - #puts "PostVariable: aryData = [array get aryData]" - set itemid $aryData(Index) - set path $aryData(Path) - set grammar [lindex $item_data($itemid) 2] - set objName [$ht_vars entry cget $var -label] - #puts "OBJECT=$objName, PATH=$path" - if { $InRootPool } { - set object $data(pool,variables,$itemid) - } else { - if {[llength $aryData(Reference)]} { - #set object [lindex $aryData(Reference) 0] - set object [lrange $aryData(Reference) 0 end] - } else { - if { [string length $tolset] } { - #set object [concat [list File $tolset] $tolindex $itemid] - set object [concat $tolset $tolindex $itemid] - #puts "tolset = $tolset" - } else { - if [llength $objName] { - set object [list $grammar $objName] - } else { - set object $objName - } - } - } - } - lappend all_objects $object - #puts "PostVariable: OBJECT=$object OBJNAME=$objName TOLSET=$tolset PATH=$path GRAMMAR=$grammar" - switch -- $grammar { - Code - - Complex - - Date - - Matrix - - VMatrix - - Polyn - - Ratio - - Real - - Serie - - Anything - - Text - - NameBlock - - TimeSet { - lappend options_selected($grammar) [list $object $objName $path] - } - Set { - # Si el objeto se da como referencia - if { [llength $object] > 1 } { - #puts "PostVariable: Set: object = $object" - if {$InRootFiles} { - set isFile 1 - } else { - set info [::tol::info var $object] - set isFile [expr [lindex $info 7] == 4] - } - #set desc [lindex $info 4] - } else { - if {[catch "::tol::info included $object" info]} { - set info [::tol::info var [list Set $objName]] - #set isFile [expr [lindex $info 5] == 4] - set isFile [expr [lindex $info 7] == 4] - #set desc [lindex $info 4] - } else { - #set info [::tol::info included $objName] - #set isFile [expr [lindex $info 4] == 4] - set isFile 1 - #set desc "" - } - } - if $isFile { - lappend options_selected(File) [list $object $objName $path] - } else { - lappend options_selected($grammar) [list $object $objName $path] - } - } - } - } - set grammar_selected [array names options_selected] - if { [llength $grammar_selected] } { - foreach grammar $grammar_selected { - switch -- $grammar { - VMatrix - - Matrix { - $data_menu(main) add cascade -label [mc "Export matrix"]\ - -menu $data_menu(Matrix,Export) - if {[llength $options_selected($grammar)] == 1} { - set object [lindex [lindex $options_selected($grammar) 0] 0] - $data_menu(main) add command -label [mc "Table matrix"] \ - -command [list ::TolInspector::TableMatrix $object] - $data_menu(Matrix,Export) add command -label "BDT" \ - -command [list ::TolInspector::ExportBDTMatrix $object] - $data_menu(main) add command -label [mc "Draw matrix"]... \ - -command [list ::TolInspector::DrawMatrix $object] - } else { - $data_menu(main) add cascade -label [mc "Table matrix"] \ - -menu $data_menu(Matrix,Table) - $data_menu(Matrix,Export) add cascade -label "BDT" \ - -menu $data_menu(Matrix,Export,BDT) - $data_menu(main) add cascade -label [mc "Draw matrix"]... \ - -menu $data_menu(Matrix,Draw) - foreach objInfo $options_selected(Matrix) { - $data_menu(Matrix,Table) add command -label [lindex $objInfo 1]\ - -command [list ::TolInspector::TableMatrix [lindex $objInfo 0]] - $data_menu(Matrix,Export,BDT) add command -label [lindex $objInfo 1]\ - -command [list ::TolInspector::ExportBDTMatrix [lindex $objInfo 0]] - $data_menu(Matrix,Draw) add command -label [lindex $objInfo 1] \ - -command [list ::TolInspector::DrawMatrix [lindex $objInfo 0]] - } - } - if { $grammar eq "Matrix" } { - set all_matrix {} - foreach m $options_selected(Matrix) { - lappend all_matrix [ lindex $m 0 ] - } - TolGui_InsertEntriesMatrixChart $data_menu(main) $all_matrix - } - } - Serie { - if {[llength $options_selected(Serie)] == 1} { - set lblSerie "serie" - } else { - set lblSerie "series" - } - $data_menu(main) add command -label [mc "Draw $lblSerie"]\ - -command ::TolInspector::DrawSerie - $data_menu(main) add command -label [mc "Table $lblSerie"]\ - -command ::TolInspector::TableSerie - if {[llength $options_selected(Serie)] == 1} { - set object [lindex [lindex $options_selected(Serie) 0] 0] - $data_menu(main) add command -label [mc "Draw autocorrelation"] \ - -command [list ::TolInspector::DrawAutocorSerie $object] - $data_menu(main) add command -label [mc "Table autocorrelation"] \ - -command [list ::TolInspector::TableAutocorSerie $object] - } else { - $data_menu(main) add cascade -label [mc "Draw autocorrelation"] \ - -menu $data_menu(Serie,DrawAutocor) - $data_menu(main) add cascade -label [mc "Table autocorrelation"] \ - -menu $data_menu(Serie,TableAutocor) - foreach objInfo $options_selected(Serie) { - $data_menu(Serie,DrawAutocor) add command -label [lindex $objInfo 1]\ - -command [list ::TolInspector::DrawAutocorSerie [lindex $objInfo 0]] - $data_menu(Serie,TableAutocor) add command -label [lindex $objInfo 1]\ - -command [list ::TolInspector::TableAutocorSerie [lindex $objInfo 0]] - } - } - $data_menu(main) add command -label [mc "Table statistics"]\ - -command ::TolInspector::TableStatisticsSerie - } - TimeSet { - if {[llength $options_selected(TimeSet)] == 1} { - set object [lindex [lindex $options_selected(TimeSet) 0] 0] - $data_menu(main) add command -label [mc "View timeset"] \ - -command [list ::TolInspector::ViewTimeSet $object] - } else { - $data_menu(main) add cascade -label [mc "View timeset"] \ - -menu $data_menu(TimeSet,View) - foreach objInfo $options_selected(TimeSet) { - $data_menu(TimeSet,View) add command -label [lindex $objInfo 1] \ - -command [list ::TolInspector::ViewTimeSet [lindex $objInfo 0]] - } - } - } - NameBlock { - # entradas desde MenuManager - if 0 { - TolGui_InsertEntriesFromMenuManager \ - $data_menu(main) \ - $options_selected(NameBlock) - } - # entradas desde @MenuDesc - # @MenuDesc sera reemplazado, ver https://www.tol-project.org/ticket/1372 - set sel_length [ llength $options_selected(NameBlock) ] - if { $sel_length } { - set idx_current [ lsearch $vars_selected $node_act ] - set all_nb_options \ - [ TolGui_GetMenuEntries \ - $options_selected(NameBlock) $idx_current ] - set num_options [ llength $all_nb_options ] - #puts "num_options = $num_options" - foreach mi $all_nb_options { - set _cname [ lindex $mi 0 ] - set cname [ string map [ list @ "" . _ ] $_cname ] - #puts "cname = $cname" - foreach { ninst obj_addr entries } [ lindex $mi 1 ] break - set instances [ lindex $mi 2 ] - if { $num_options > 1 } { - # creo el menu de la clase si no existe - set mclass $data_menu(main).cls$cname - if { ![ winfo exists $mclass ] } { - menu $mclass -tearoff 0 - } else { - $mclass delete 0 end - } - $data_menu(main) add cascade -label $cname -menu $mclass - set target_menu $mclass - } else { - set target_menu $data_menu(main) - } - foreach inst_entry $entries { - foreach { label single group } $inst_entry break - set opt_label \ - "$label [ expr { $sel_length>1 ? $ninst : {} } ]" - $target_menu add command -label $opt_label \ - -command [ list TolGui_InvokeMethod \ - $single $obj_addr ] - if { $group ne "" && [ llength $instances ] > 1 } { - # hay una funcion que se aplica a toda la seleccion - $target_menu add command -label "$label All" \ - -command [ list TolGui_InvokeGroup \ - $_cname $group $instances ] - } - } - } - } - } - Set { - if {[llength $options_selected(Set)] == 1} { - set object [lindex [lindex $options_selected(Set) 0] 0] - $data_menu(main) add command -label [mc "Table set"] \ - -command [list ::TolInspector::TableSet $object] - $data_menu(main) add command -label [mc "Draw set"] \ - -command [list ::TolInspector::DrawSet $object] - # menu special - $data_menu(main) add cascade -label [mc "Draw set special"] \ - -menu $data_menu(Set,Draw,Special) - $data_menu(Set,Draw,Special) add command \ - -label [mc SetGraphAllFirst] \ - -command [list ::TolInspector::DrawSet $object 1] - $data_menu(Set,Draw,Special) add command \ - -label [mc SetGraphAllGeneric] \ - -command [list ::TolInspector::DrawSet $object 2] - $data_menu(Set,Draw,Special) add command \ - -label [mc SetGraphEvenUneven] \ - -command [list ::TolInspector::DrawSet $object 3] - } else { - $data_menu(main) add cascade -label [mc "Table set"] \ - -menu $data_menu(Set,Table) - $data_menu(main) add cascade -label [mc "Draw set"] \ - -menu $data_menu(Set,Draw) - foreach objInfo $options_selected(Set) { - $data_menu(Set,Table) add command -label [lindex $objInfo 1] \ - -command [list ::TolInspector::TableSet [lindex $objInfo 0]] - $data_menu(Set,Draw) add command -label [lindex $objInfo 1] \ - -command [list ::TolInspector::DrawSet [lindex $objInfo 0]] - } - # menu special - set i 0 - $data_menu(main) add cascade -label [mc "Draw set special"] \ - -menu $data_menu(Set,Draw,Special,M) - foreach objInfo $options_selected(Set) { - # exists menu previus ? - if {[winfo exists $data_menu(Set,Draw,Special,M).setdrawspecialm$i]} { - destroy $data_menu(Set,Draw,Special,M).setdrawspecialm$i - } - set mn \ - [menu $data_menu(Set,Draw,Special,M).setdrawspecialm$i \ - -tearoff 0] - $data_menu(Set,Draw,Special,M) add cascade \ - -label [lindex $objInfo 1] -menu $mn - $mn add command -label [mc SetGraphAllFirst] \ - -command [list ::TolInspector::DrawSet [lindex $objInfo 0] 1] - $mn add command -label [mc SetGraphAllGeneric] \ - -command [list ::TolInspector::DrawSet [lindex $objInfo 0] 2] - $mn add command -label [mc SetGraphEvenUneven] \ - -command [list ::TolInspector::DrawSet [lindex $objInfo 0] 3] - incr i - } - } - } - File { - if {[llength $options_selected(File)] == 1} { - set objName [lindex [lindex $options_selected(File) 0] 1] - $data_menu(main) add command -label [mc "View file"] \ - -command [list ::TolInspector::ViewFile $objName] - if $InRootFiles { - $data_menu(main) add command -label [mc "Decompile file"] \ - -command [list ::TolInspector::DecompileFile $objName] - } - } else { - $data_menu(main) add cascade -label [mc "View file"] \ - -menu $data_menu(File,View) - foreach objInfo $options_selected(File) { - $data_menu(File,View) add command -label [lindex $objInfo 1] \ - -command [list ::TolInspector::ViewFile [lindex $objInfo 1]] - } - if $InRootFiles { - $data_menu(main) add cascade -label [mc "Decompile file"] \ - -menu $data_menu(File,Decompile) - foreach objInfo $options_selected(File) { - $data_menu(File,Decompile) add command -label [lindex $objInfo 1] \ - -command [list ::TolInspector::DecompileFile [lindex $objInfo 1]] - } - } - } - } - } ;# end del switch - # inserto las opciones definidas en MenuManager - if { $grammar ne "Anything" } { - TolGui_InsertEntriesFromMenuManager \ - $data_menu(main) \ - $options_selected($grammar) - } - - $data_menu(main) add separator - $data_menu(main) add cascade -label [mc "Functions"] \ - -menu $data_menu($grammar,Functions) - ShowMenuUserFunc $grammar - if {[llength $options_selected($grammar)] == 1} { - set objName [lindex [lindex $options_selected($grammar) 0] 1] - set path [lindex [lindex $options_selected($grammar) 0] 2] - $data_menu(main) add command -label [mc "View %1\$s's definition" $grammar] \ - -command [list ::TolInspector::ViewDefinition $objName $path $grammar] - } else { - $data_menu(main) add cascade -label [mc "View %1\$s's definition" $grammar] \ - -menu $data_menu($grammar,File) - foreach objInfo $options_selected($grammar) { - $data_menu($grammar,File) add command -label [lindex $objInfo 1] \ - -command [list ::TolInspector::ViewDefinition\ - [lindex $objInfo 1] [lindex $objInfo 2] $grammar] - } - } - $data_menu(main) add separator - } ;#end del foreach - - # Store selection in oza - if { [ llength $all_objects ] > 1 || [ lindex $grammar_selected 0 ] ne "Set" } { - $data_menu(main) add command -label [mc "Store selection in OZA"]... \ - -command [ list TolGui_StoreSelectionInOZA $all_objects ] - } else { - $data_menu(main) add command -label [mc "Store Set in OZA"]... \ - -command [ list TolGui_StoreSelectionInOZA $all_objects ] - $data_menu(main) add command -label [mc "Store elements in OZA"]... \ - -command [ list TolGui_StoreSetElementsInOZA [ lindex $all_objects 0 ] ] - } - $data_menu(main) add separator - # Store selection in oza - - if { $InRootPool } { - $data_menu(main) add command -label [mc "Remove from spool"] \ - -command [list ::TolInspector::RemoveFromSpool $ht_vars] - } else { - $data_menu(main) add command -label [mc "Add to spool"] \ - -command [list ::TolInspector::AddToSpool $ht_vars [lindex [$ht_tree get -full anchor] 1]] - } - $data_menu(main) add command -label [mc "To Eval window"] \ - -command [list ::TolInspector::AddToEvalWindow $ht_vars] - $data_menu(main) add separator - if { $InRootConsole} { - $data_menu(main) add command -label [mc "Decompile"] \ - -command [list ::TolInspector::ClearConsoleObjSel $ht_vars] - $data_menu(main) add separator - } - $data_menu(main) add command -label [mc "Select all"] \ - -command [list ::TolInspector::SelectAll $ht_vars] - $data_menu(main) add command -label [mc "Toggle selection"] \ - -command [list ::TolInspector::ToggleSelection $ht_vars] - tk_popup $data_menu(main) $x $y - } ;#end del if - } - } -} - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::PostFunction { x y } { -# -# PURPOSE: Composes a popup menu for functions and displays it. Its composed -# depending on the node/s clicked by user. -# -# PARAMETERS: -# x -> x-coordinate where popup menu is drawn -# y -> y-coordinate where popup menu is drawn -# -#///////////////////////////////////////////////////////////////////////////// - variable data_menu - variable vars_selected - variable ht_funcs - variable ht_tree - variable item_data - variable data - - variable tolset - variable tolindex - - array unset options_selected - foreach it [array names data_menu] { - $data_menu($it) delete 0 end - } - - set InRootPool [string equal [lindex [$ht_tree get -full anchor] end] "root-pool"] - set node_act [$ht_funcs index current] - if { [string length $node_act] } { - set vars_selected [$ht_funcs curselection] - if { [lsearch $vars_selected $node_act] >= 0 } { - foreach var $vars_selected { - array set aryData [$ht_funcs entry cget $var -data] - set itemid $aryData(Index) - set path $aryData(Path) - set grammar [lindex $item_data($itemid) 2] - set objName [$ht_funcs entry cget $var -label] - - if { $InRootPool } { - set object $data(pool,variables,$itemid) - } else { - if { [string length $tolset] } { - set object [concat [list $tolset] $tolindex $itemid] - } else { - set object $objName - } - } - # La única gramática seleccionable en ht_funcs es Code - lappend code_selected [list $object $objName $path] - } - - if {[llength $code_selected] == 1} { - set objName [lindex [lindex $code_selected 0] 1] - set path [lindex [lindex $code_selected 0] 2] - $data_menu(main) add command -label [mc "View %1\$s's definition" $grammar] \ - -command [list ::TolInspector::ViewDefinition $objName $path $grammar] - } else { - $data_menu(main) add cascade -label [mc "View %1\$s's definition" $grammar] \ - -menu $data_menu($grammar,File) - foreach objInfo $code_selected { - $data_menu($grammar,File) add command -label [lindex $objInfo 1]\ - -command [list ::TolInspector::ViewDefinition\ - [lindex $objInfo 1] [lindex $objInfo 2] $grammar] - } - } - - if { $InRootPool } { - $data_menu(main) add command -label [mc "Remove from spool"] \ - -command [list ::TolInspector::RemoveFromSpool $ht_funcs] - } else { - $data_menu(main) add command -label [mc "Add to spool"] \ - -command [list ::TolInspector::AddToSpool $ht_funcs [lindex [$ht_tree get -full anchor] 1]] - } - $data_menu(main) add command -label [mc "To Eval window"] \ - -command [list ::TolInspector::AddToEvalWindow $ht_funcs] - $data_menu(main) add separator - $data_menu(main) add command -label [mc "Select all"] \ - -command [list ::TolInspector::SelectAll $ht_funcs] - $data_menu(main) add command -label [mc "Toggle selection"] \ - -command [list ::TolInspector::ToggleSelection $ht_funcs] - tk_popup $data_menu(main) $x $y - } - } -} - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::PostTree { x y } { -# -# PURPOSE: Composes a popup menu for left treeview and displays it. Its -# composed depending on the node clicked by user. -# -# PARAMETERS: -# x -> x-coordinate where popup menu is drawn -# y -> y-coordinate where popup menu is drawn -# -#///////////////////////////////////////////////////////////////////////////// - variable data_menu - variable vars_selected - variable ht_tree - variable item_data - variable data - variable tolset - variable tolindex - variable item_id - #puts "ht_tree: $ht_tree" - #No terminado todavía - #return - array unset options_selected - - #puts "::TolInspector::PostTree $x $y" - foreach it [array names data_menu] { - $data_menu($it) delete 0 end - } - set InRootPool [string equal [lindex [$ht_tree get -full anchor] end-1] "root-pool"] - #puts "InRootPool: $InRootPool" - # InRootFiles has a value 1 if node is a File - set InRootFiles [string equal [lindex [$ht_tree get -full anchor] end-1] "root-files"] - #puts "InRootFiles: $InRootFiles" - # index of the selected node - set node_act [$ht_tree index current] - #puts "node_act: $node_act" - if { [string length $node_act] } { - set vars_selected [$ht_tree curselection] - #puts "vars_selected: $vars_selected" - if { [lsearch $vars_selected $node_act] >= 0 } { ;# Not root node - set index [$ht_tree index anchor] - #puts "index: $index" - if { $index } { - set info_node [split [lindex [$ht_tree get -full $index] end] "-"] - #puts "info_node: $info_node" - set node_type [lindex $info_node 0] - #puts "node_type: $node_type" - set node_name [lindex $info_node 1] - #puts "node_name: $node_name" - } else { ;# root node - set node_type root - set node_name root - } - # if user selects a root or a grammar doesn't nothing - switch -regexp $node_type { - root - - grammar { return } - } - # label of object showed in the tree - set objName [$ht_tree entry cget $index -label] - #puts "objName: $objName" - set object $objName - - if {$InRootFiles} { - array set aryData [$ht_tree entry cget $index -data] - if [info exist aryData(FileName)] { - set objName $aryData(FileName) - } - } - #puts "2objName: $objName" - if { $InRootPool } { - #puts "es InRootPool $item_id" - set itemid $item_id - #set object $data(pool,variables,$itemid) - set object $data(pool,reference,$node_type) - } else { - #puts "NO InRootPool" - if { [string length $tolset] } { - set object [concat [list $tolset] $tolindex] - } else { - set object $objName - } - } - #puts "object = $objName '[$ht_tree entry cget $index -data]'" -#Tolcon_Trace "***********************************" {red} -#Tolcon_Trace "index=$index, node_type=$node_type, node_name=$node_name" {red} -#Tolcon_Trace "tolset=$tolset, tolindex=$tolindex, aryData= [$ht_tree entry cget $index -data]" {red} -#Tolcon_Trace "object=$object, label=$objName" {red} -#Tolcon_Trace "***********************************" {red} - - # - # TICKET: #1438 - # Por que se pregunta aqui por los objetos de consola? - # - set stackList [::tol::console stack list] - #puts "stackList: $stackList" - set stackValue {} - foreach stackItem $stackList { - #puts "stackItem: $stackItem" - #puts "lindex $stackValue 1: [lindex $stackValue 1]" - #puts "objName: $objName" - if {[lindex $stackItem 1] eq $objName} { - set stackValue $stackItem - } - break - } - #puts "stackValue: $stackValue" - set grammar [lindex $stackValue 0] - #puts "grammar: $grammar" - #set full_data $item_data($index) ;# {value} {desc} {grammar} - #set grammar [lindex $full_data 2] - - #foreach fun [::tol::info functions $grammar] { - # set finfo [::tol::info functions $grammar $fun] - # InsertChild Code $fun [lindex $finfo 0] [lindex $finfo 1] [list [lindex $finfo 2]] 0 - #} - if {[catch {set info [::tol::info included $objName]}]} { - if { !($grammar eq "")} { - if {[catch {set info [::tol::info var [list $grammar $object]}]} { - #set info [concat [list "$grammar" $objName ] [::tol::info var $grammar $objName]] - set info [::tol::info var [list $grammar $objName]] - #Tolcon_Trace "INFO de ::tol::info var Set objName" - } else { - set info [::tol::info var [list $grammar $object]] - #Tolcon_Trace "INFO de ::tol::info var $grammar object" - } - set isFile [expr [lindex $info 5] == 4] - } else { - set isFile 0 - } - - } else { - set info [::tol::info included $objName] - #Tolcon_Trace "INFO de ::tol::info included objName" - set isFile 1 - } - #puts "paso" - - if $isFile { - #puts "entro como fichero" - $data_menu(main) add command -label [mc "View file"] \ - -command [list ::TolInspector::ViewFile $objName] - if $InRootFiles { - $data_menu(main) add command -label [mc "Decompile file"] \ - -command [list ::TolInspector::DecompileFile $objName] - } - } else { - #puts "no entro como fichero" - if { $grammar eq "Set" } { - $data_menu(main) add command -label [mc "Table set"] \ - -command [list ::TolInspector::TableSet $object] - $data_menu(main) add command -label [mc "Draw set"] \ - -command [list ::TolInspector::DrawSet $object] - } - } - tk_popup $data_menu(main) $x $y - } - } -} - - -#///////////////////////////////////////////////////////////////////////////// -# Procedures asociated with tol inspector popup menu -#///////////////////////////////////////////////////////////////////////////// - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::RemoveFromSpool {ht} { -# -# PURPOSE: Removes from spool all selected objects -# -#///////////////////////////////////////////////////////////////////////////// - variable vars_selected - variable item_data - variable tolset - variable tolindex - variable data - - foreach var $vars_selected { - array set aryData [$ht entry cget $var -data] - set itemid $aryData(Index) - set path $aryData(Path) - set reference $aryData(Reference) - set grammar [lindex $item_data($itemid) 2] - - set objName [$ht entry cget $var -label] - - set _objpool [list "grammar" $grammar "objName" $objName "reference" $reference "path" $path] - if {$grammar eq "Code"} { - set graApply [lindex $aryData(Content) 0] - lappend _objpool "graApply" $graApply - } - #Tolcon_Trace "OBJPOOL on REMOVE: $_objpool" - - # Buscamos el objeto (identificador: referencia) - array set objpool $_objpool - foreach _obj $data(pool,objects) { - array set obj $_obj - #Tolcon_Trace "obj(reference)=$obj(reference), objpool(reference)=$objpool(reference)" - if {[string equal $obj(reference) $objpool(reference)]} { - if {$obj(grammar) eq "Code"} { - if {[string equal $obj(graApply) $objpool(graApply)]} { - set idx [lsearch $data(pool,objects) $_obj] - #Tolcon_Trace "El obj a quitar tiene idx=$idx" - set data(pool,objects) [lreplace $data(pool,objects) $idx $idx] - } - } else { - set idx [lsearch $data(pool,objects) $_obj] - #Tolcon_Trace "El obj a quitar tiene idx=$idx" - set data(pool,objects) [lreplace $data(pool,objects) $idx $idx] - } - } - } - } - #Tolcon_Trace "P.O. after REMOVE: $data(pool,objects)" - UpdatePoolObj -} - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::AddToSpool {ht origin} { -#///////////////////////////////////////////////////////////////////////////// - variable vars_selected - variable item_data - variable tolset - variable tolindex - variable data - - foreach var $vars_selected { - array set aryData [$ht entry cget $var -data] - set itemid $aryData(Index) - set path $aryData(Path) - set grammar [lindex $item_data($itemid) 2] - set objName [$ht entry cget $var -label] - #puts "AddToSpool: Reference=$aryData(Reference) tolset=$tolset grammar=$grammar" - if {[llength $aryData(Reference)]} { - set reference $aryData(Reference) - } else { - if { [string length $tolset] } { - #set object [concat [list $tolset] $tolindex $itemid] - #set object [concat [list File $tolset] $tolindex $itemid] - set object [concat $tolset $tolindex $itemid] - #puts "AddToSpool: object=$object" - set reference [::tol::info reference $object] - } else { - if {$grammar eq "Set"} { - #puts "AddToSpool: origin=$origin" - set reference [::tol::info reference [list Set $objName]] - #Tolcon_Trace "reference de ::tol::info reference [list $objName]" - } else { - if [catch {set reference [::tol::info reference [list $grammar $objName]]}] { - set reference $objName - #Tolcon_Trace "reference NO SE QUE PONER" - } - #Tolcon_Trace "reference de ::tol::info reference $grammar $objName" - } - } - } - set _objpool [list "origin" $origin "grammar" $grammar "objName" $objName "reference" $reference "path" $path] - if {$grammar eq "Code"} { - set graApply [lindex $aryData(Content) 0] - lappend _objpool "graApply" $graApply - } - #Tolcon_Trace "***************" - #Tolcon_Trace "OBJPOOL on ADD:" - #Tolcon_Trace "***************" - #foreach {key value} $_objpool { - # Tolcon_Trace " $key=$value" - #} - set inserted 0 - # Si la referencia es igual, el objeto es el mismo (salvo para obj de tipo Code) - array set objpool $_objpool - foreach _obj $data(pool,objects) { - array set obj $_obj - if {[string equal $obj(reference) $objpool(reference)]} { - #Si es de la gramatica Code miro a ver la gramatica sobre la que se aplica - if {$objpool(grammar) eq "Code"} { - if {[string equal $obj(graApply) $objpool(graApply)]} { - set inserted 1 - } - } else { - set inserted 1 - } - } - } - if {!$inserted} { - lappend data(pool,objects) $_objpool - #puts "AddToSpool: P.O. after ADD: $data(pool,objects)" - } else { - #puts "$_objpool ALREADY IN SPOOL" - } - } - -} - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::AddToEvalWindow {ht} { -# -# PURPOSE: Adds names of selected objects (vars or functions) in treeview ht -# to eval window -# -#///////////////////////////////////////////////////////////////////////////// - variable ht_vars - variable vars_selected - - set names "" - foreach var $vars_selected { - lappend names [$ht entry cget $var -label] - } - ::TolConsole::ToEvalWindow [ListToStr $names] -} - - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::SelectAll {ht} { -# -# PURPOSE: Selects all nodes of a given treeview -# -# PARAMETERS: -# ht -> treeview's path -# -#///////////////////////////////////////////////////////////////////////////// - set found [$ht find] - if {[llength $found] > 1} { - $ht selection set [lindex $found 1] [lindex $found end] - } -} - - -#///////////////////////////////////////////////////////////////////////////// - proc ::TolInspector::ToggleSelection {ht} { -# -# PURPOSE: Toggles selection of nodes of a given treeview -# -# PARAMETERS: -# ht -> treeview's path -# -#///////////////////////////////////////////////////////////////////////////// - set found [$ht find] - if {[llength $found] > 1} { - $ht selection toggle [lindex $found 1] [lindex $found end] - } -} - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::DrawSet {setref {type 0}} { -# -# PURPOSE: Graph a Set. For it it calls to a form for the selection of -# columns to graph -# -# PARAMETERS: -# setref -> Set to graph -# type -> 0 for custom association of data columns -# -> 1 for all data columns to first one -# -> 2 for all data columns to generic -# -> 3 for even data columns to odd ones -# -#///////////////////////////////////////////////////////////////////////////// - variable group_id - variable w_tabset - #puts "::TolInspector::DrawSet. setref: $setref" - incr group_id - if {[llength $setref] > 1} { - set name [lindex [::tol::info variable $setref] 1] - } else { - set name $setref - } - set cmd tablecmd$group_id - if {![catch {::tol::tableset create $cmd $setref}]} { - switch $type { - 0 { - set tl [::project::CreateForm \ - -width 500 -height 500 -type Graphs \ - -iniconfig Graph \ - -title [mc "Set graph: %s" $name] -helpkey "Tb4GraSet"] - $tl withdraw - set tlf [$tl getframe] - if {[set Instance [::SetGraphDialog::Init $tlf.g $cmd $setref]] != 0} { - bind $tlf.g +[list ::tol::tableset destroy $cmd] - pack $tlf.g -fill both -expand yes - $tl restore - update - # Esta opción se debe aplicar cuando el gráfico esté empacado - ::bayesGraph::GrapOptApplyAxisTicks $Instance ${Instance}::options gr,0 - } else { - destroy $tl - return - } - $tl bind [list $tl kill] - } - 1 - - 2 - - 3 { - # windows - set tl [::project::CreateForm \ - -title [mc "Set graph: %s" $name] -type Graphs -iniconfig SetGraph] - $tl withdraw - set tlf [$tl getframe] - set Instance [::SetGraphDialog::DrawSet $tlf.g $cmd $setref $type] - bind $tlf.g +[list ::tol::tableset destroy $cmd] - pack $tlf.g -fill both -expand yes - $tl restore - update - # Esta opción se debe aplicar cuando el gráfico esté empacado - ::bayesGraph::GrapOptApplyAxisTicks $Instance ${Instance}::options gr,0 - } - } - } else { - tk_messageBox -type ok -icon warning \ - -message [mc "Set is not graficable: %s" $::errorInfo] \ - -parent $w_tabset -title [mc "Warning"] - } -} - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::DrawMatrix {matref} { -# -# PURPOSE: draw the given matrix -# -# PARAMETERS: -# matref -> reference to the tol matrix -# -#///////////////////////////////////////////////////////////////////////////// - variable group_id - variable w_tabset - - incr group_id - if {[llength $matref] > 1} { - set name [lindex [::tol::info variable $matref] 1] - } else { - if { ([info exists obj]) } { - set name $obj - } - } - if { ([info exists name]) } { - set cmd tablecmd$group_id - if {![catch {::tol::tablematrix create $cmd $matref}]} { - set tl [::project::CreateForm \ - -width 500 -height 500 -type Graphs \ - -iniconfig Graph \ - -title [mc "Matrix graph: %s" $name] -helpkey "Tb4Gra"] - $tl withdraw - - set tlf [$tl getframe] - if {[set Instance [::SetGraphDialog::Init $tlf.g $cmd $matref]] != 0} { - bind $tlf.g +[list ::tol::tablematrix destroy $cmd] - pack $tlf.g -fill both -expand yes - $tl restore - update - # Esta opción se debe aplicar cuando el gráfico esté empacado - ::bayesGraph::GrapOptApplyAxisTicks $Instance ${Instance}::options gr,0 - } else { - destroy $tl - return - } - $tl bind [list $tl kill] - } else { - tk_messageBox -type ok -icon warning \ - -message [mc "Matrix is not graficable: %s" $::errorInfo] \ - -parent $w_tabset -title [mc "Warning"] - } - } -} - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::TableSet { set } { -#///////////////////////////////////////////////////////////////////////////// - variable w_tabset - variable group_id - - incr group_id - if {[llength $set] > 1} { - set nameSet [lindex [::tol::info variable $set] 1] - } else { - set nameSet $set - } - set setgrp group$group_id - if {![catch {::tol::tableset create $setgrp $set}]} { - # create - set tl [::project::CreateForm \ - -title "[mc "Set table"]: $nameSet" \ - -iniconfig SetTable \ - -type Tables -helpkey "Tb4Edt" - ] - set tlf [$tl getframe] - # config - btable $tlf.t -parent $tl \ - -posteditcmd [list ::TolConsole::TableRecentUpdate $tlf.t] \ - -iniconfig btable - $tlf.t fillSet $setgrp - pack $tlf.t -fill both -expand yes - bind $tlf.t +[list ::tol::tableset destroy $setgrp] - $tl bind [list $tl kill] - update - } else { - tk_messageBox -type ok -icon warning -message [mc "Set not tabulable"]\ - -parent $w_tabset -title [mc Warning] - } -} - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::TableMatrix { matrix } { -#///////////////////////////////////////////////////////////////////////////// - set mattb [::tol::matrix $matrix] - # create - set tl [::project::CreateForm \ - -title "[mc {Matrix table}]: [lindex $mattb 0]" \ - -iniconfig MatrixTable \ - -type Tables -helpkey "Tb4Edt" - ] - set tlf [$tl getframe] - # create matrix - btable $tlf.t -parent $tl \ - -posteditcmd [list ::TolConsole::TableRecentUpdate $tlf.t] \ - -iniconfig btable - $tlf.t fillMatrix $mattb - $tl bind [list $tl kill] - pack $tlf.t -fill both -expand yes - - #if {$grammar == "VMatrix"} { - #::tol::console stack release "zxw._.wxz" - #} -} - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::ExportBDTMatrix { matrix } { -#///////////////////////////////////////////////////////////////////////////// - variable group_id - - incr group_id - set tl [toplevel .top$group_id] - wm title $tl "ExportBDTMatrix" - - #pack $tl.t -fill both -expand yes -} - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::DrawSerie { } { -#///////////////////////////////////////////////////////////////////////////// - variable options_selected - upvar \#0 ::TolInspector::options_selected(Serie) series_selected - - #puts "DrawSerie: series_selected=$series_selected" - set series "" - foreach it $series_selected { - lappend series [lindex $it 0] - } - DrawSeries $series -} - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::DrawSeries { series {gcf ""}} { -#///////////////////////////////////////////////////////////////////////////// - variable group_id - - if { [llength $series] } { - incr group_id - # series - set sergrp group$group_id - set t0 [time { - eval "::tol::seriegrp create $sergrp $series" - }] - # name - set name [$sergrp serie 0 name] - if { [$sergrp serie size] > 1} { - set name ${name}... - } - # create - set t1 [time { - set tl [::project::CreateForm \ - -title [mc "Series graph: %s" $name] \ - -type Graphs \ - -iniconfig SeriesGraph \ - -width 900 -height 650 -helpkey "Tb4GraSer" - ]}] - set tlf [$tl getframe] - # configuration - set t2 [time { - set Instance [::SeriesGraph::Create $tlf.g $sergrp] - }] - #puts "t0 = $t0" - #puts "t1 = $t1" - #puts "t2 = $t2" - if { $gcf != "" } { - ::bayesGraph::LoadGCF $Instance $gcf - } - bind $tlf.g +[list ::tol::seriegrp destroy $sergrp] - pack $tlf.g -fill both -expand yes - $tl bind [list $tl kill] - update - # Esta opción se debe aplicar cuando el gráfico esté empacado - #::bayesGraph::GrapOptApplyAxisTicks $Instance ${Instance}::options gr,0 - } -} - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::DrawAutocorSerie { serie } { -#///////////////////////////////////////////////////////////////////////////// - variable group_id - - incr group_id - # title - - if {[llength $serie] > 1} { - set nameSerie [lindex [::tol::info variable $serie] 1] - } else { - set nameSerie $serie - } - # create - set tl [::project::CreateForm \ - -title "[mc "Autocorrelation graph"]: $nameSerie" \ - -iniconfig AutocorGraph \ - -type Graphs \ - -width 900 -height 650 -helpkey "Tb4GraAco" - ] - set tlf [$tl getframe] - # configuration - ::AutocorGraph::Create $tlf.g $serie - $tl bind "$tl kill; break" - pack $tlf.g -fill both -expand yes - update -} - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::TableSerie { } { -#///////////////////////////////////////////////////////////////////////////// - variable options_selected - variable group_id - upvar \#0 ::TolInspector::options_selected(Serie) series_selected - - set series "" - foreach it $series_selected { - lappend series [lindex $it 0] - } - - if { [llength $series] } { - incr group_id - - set sergrp group$group_id - eval "::tol::seriegrp create $sergrp $series" - - # create - set tl [::project::CreateForm \ - -title [mc "Time series table"] \ - -iniconfig SeriesTable \ - -type Tables -helpkey "Tb4Edt" - ] - set tlf [$tl getframe] - # configuration - btable $tlf.t -parent $tl \ - -posteditcmd [list ::TolConsole::TableRecentUpdate $tlf.t] \ - -iniconfig btable - $tlf.t fillSerie $sergrp - bind $tlf.t +[list ::tol::seriegrp destroy $sergrp] - pack $tlf.t -fill both -expand yes - $tl bind [list $tl kill] - update - } -} - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::TableAutocorSerie { serie } { -#///////////////////////////////////////////////////////////////////////////// - variable group_id - - incr group_id - # title - if {[llength $serie] > 1} { - set nameSerie [lindex [::tol::info variable $serie] 1] - } else { - set nameSerie $serie - } - # create - set tl [::project::CreateForm \ - -title "[mc "Autocorrelation table"]: $nameSerie" \ - -iniconfig AutocorGraphTable \ - -type Tables -helpkey "Tb4Edt" - ] - set tlf [$tl getframe] - # configuration - btable $tlf.t -parent $tl \ - -posteditcmd [list ::TolConsole::TableRecentUpdate $tlf.t] \ - -iniconfig btable - $tlf.t fillAutocor $serie "" - $tl bind [list $tl kill] - pack $tlf.t -fill both -expand yes -} - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::TableStatisticsSerie { } { -#///////////////////////////////////////////////////////////////////////////// - variable options_selected - variable group_id - upvar \#0 ::TolInspector::options_selected(Serie) series_selected - - set series "" - foreach it $series_selected { - lappend series [lindex $it 0] - } - - if { [llength $series] } { - incr group_id - - set sergrp group$group_id - eval "::tol::seriegrp create $sergrp $series" - # create - set tl [::project::CreateForm \ - -title [mc "Statistics table"] \ - -iniconfig StatisticsTable \ - -type Tables -helpkey "Tb4Edt" - ] - set tlf [$tl getframe] - # configuration - btable $tlf.t -parent $tl \ - -posteditcmd [list ::TolConsole::TableRecentUpdate $tlf.t] \ - -iniconfig btable - $tlf.t fillStatistics $sergrp - bind $tlf.t +[list ::tol::seriegrp destroy $sergrp] - $tl bind [list $tl kill] - pack $tlf.t -fill both -expand yes - } -} - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::ViewTimeSet { tms args } { -#///////////////////////////////////////////////////////////////////////////// - variable group_id - - incr group_id - - #puts "::TolInspector::ViewTimeSet $tms" - # args - array set opts [list \ - -title "[mc "TimeSet calendar"]: $tms" \ - -geometry {} - ] - array set opts $args - - # create - set tl [::project::CreateForm \ - -title $opts(-title) \ - -iniconfig Calendar \ - -type TimeSets -width 470 -height 345 -helpkey "Tb4Cal" - ] - # geometry - $tl setgeometry $opts(-geometry) - - set tlf [$tl getframe] - # configuration - set tmscmd tms$group_id - ::tol::timeset create $tmscmd $tms - ::CalendarTms::Create $tlf.t $tmscmd - bind $tlf.t +[list ::tol::timeset destroy $tmscmd] - bind $tl [list $tl kill] - pack $tlf.t -fill both -expand yes - - return $tl -} - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::ViewDefinition {name path grammar} { -#///////////////////////////////////////////////////////////////////////////// - variable w_tabset - if {$path == ""} { - tk_messageBox -type ok -icon warning\ - -message [mc "Object %1\$s is not defined in a tol file" $name]\ - -parent $w_tabset -title [mc Warning] - return - } - set ext [file extension $path] - switch -- $ext { - .tol - - .TOL { - set Instance [::Editor::Open $path] - update - if {[string equal $grammar "Code"] || - [string equal $grammar "Anything"]} { - append txtFind " " $name "( )*\\(" - } else { - #append txtFind $grammar "( )+" $name - append txtFind $name - } - #Me situo al principio del texto - set editor [::Editor::GetText $Instance] - tk::TextSetCursor $editor 1.0 - ::BayesText::FindShow $editor 1 $txtFind 1 - #::Editor::CmdFindNext $Instance $txtFind - } - .bst - - .BST - - .bdt - - .BDT { - # Igual luego se abre como tabla - ::Editor::Open $path - } - } -} - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::ViewFile {name} { -# -# PURPOSE: -# -# PARAMETERS: -# name -> cadena con el nombre de un archivo o el de una variable -# que hace referencia a un archivo -# -#///////////////////////////////////////////////////////////////////////////// - # En name puede venir el nombre de un archivo o el de una variable - # que hace referencia a un archivo. - #puts "ViewFile. name=$name" - if [file isfile $name] { - set path $name - } else { - set path [::tol::info path $name] - } - ::Editor::Open $path -} - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::DecompileFile {name} { -# -# PURPOSE: -# -# PARAMETERS: -# name -> cadena con el nombre de un archivo o el de una variable -# que hace referencia a un archivo -# -# TODO: Actualmente en name solo puede llegar el nombre de un archivo -# -#///////////////////////////////////////////////////////////////////////////// - variable data - #puts "DECOMPILE 1.1, name=$name" - if {[file isfile $name]} { - set path $name - } else { - set path [::tol::info path $name] - } - #puts "DECOMPILE 1.2" - #Comprobar si el archivo ya está abierto y si es así poner que no está compilado - if [namespace exists ::Editor] { - foreach ins [namespace children ::Editor] { - upvar \#0 ${ins}::data dataEd - if [string equal $dataEd(nameFile) $path] { - set dataEd(isCompiled) 0 - } - } - } - #puts "DECOMPILE 1.3" - #Quitar del spool todos los objetos provenientes de este archivo - - foreach _obj $data(pool,objects) { - array set obj $_obj - #Tolcon_Trace "REFERENCIA: $obj(reference)" - if {[string equal [lindex $obj(reference) 0] $path]} { - set idx [lsearch $data(pool,objects) $_obj] - set data(pool,objects) [lreplace $data(pool,objects) $idx $idx] - } - } - # https://www.tol-project.org/ticket/1483 - catch { - ::tol::decompile $path - } - ::TolInspector::UpdateFileRoot -} - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::ReadUserFunctions {} { -# -# PURPOSE: Recorre el set global que tiene la definicion de funciones y va -# guardando esa informacion en arrays para almacenarla finalmente en -# regFunLst -# -#///////////////////////////////////////////////////////////////////////////// - variable regFunLst - - #Set global que tiene la definicion de funciones - set obj GuiFunction - - if { [llength [set infAry [TclInfoVar Set $obj]] ] } { - #Tolcon_Trace "ReadUserFunctions: infAry = $infAry" - array set info $infAry - set nFun [lindex $info(CONTENT) 0] - #Tolcon_Trace "Numero de funciones =$nFun" - for {set idf 1} {$idf <= $nFun} {incr idf} { - array set ifNameFun [TclInfoRef [list Set $obj $idf 1]] - array set ifNameGui [TclInfoRef [list Set $obj $idf 2]] - array set ifTypeGui [TclInfoRef [list Set $obj $idf 3]] - array set ifTypeOut [TclInfoRef [list Set $obj $idf 4]] - array set ifParams [TclInfoRef [list Set $obj $idf 5]] - #Hago lindex $a(CONTENT) 0 para quitar las comillas - set regFun($idf,nameFun) [lindex $ifNameFun(CONTENT) 0] - set regFun($idf,nameGui) [lindex $ifNameGui(CONTENT) 0] - set regFun($idf,typeGui) [lindex $ifTypeGui(CONTENT) 0] - set regFun($idf,typeOut) [lindex $ifTypeOut(CONTENT) 0] - set nPar [lindex $ifParams(CONTENT) 0] - #Tolcon_Trace "Numero de parametros =$nPar" - for {set idp 1} {$idp <= $nPar} {incr idp} { - array set ipNameGui [TclInfoRef [list Set $obj $idf 5 $idp 1]] - array set ipTypePar [TclInfoRef [list Set $obj $idf 5 $idp 2]] - array set ipTypeSel [TclInfoRef [list Set $obj $idf 5 $idp 3]] - array set ipListVal [TclInfoRef [list Set $obj $idf 5 $idp 4]] - set regPar($idp,nameGui) [lindex $ipNameGui(CONTENT) 0] - set regPar($idp,typePar) [lindex $ipTypePar(CONTENT) 0] - set regPar($idp,typeSel) $ipTypeSel(CONTENT) - set nVal [lindex $ipListVal(CONTENT) 0] - #Tolcon_Trace "nVal=$nVal" - set lstVal "" - for {set idv 1} {$idv <= $nVal} {incr idv} { - array set iVal [TclInfoRef [list Set $obj $idf 5 $idp 4 $idv]] - lappend lstVal [lindex $iVal(CONTENT) 0] - } - set regPar($idp,lstVal) $lstVal - } - set regFun($idf,parameters) [array get regPar] - array unset regPar - #parray regFun - } - set regFunLst [array get regFun] - } else { - set regFunLst "" - } -} - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::ShowMenuUserFunc {gra} { -# -# PURPOSE: Muestra un menu contextual que... -# -#///////////////////////////////////////////////////////////////////////////// - variable data_menu - variable regFunLst - - #puts "ShowMenuUserFunc: gra=$gra" - if {[expr [info exist ::TolInspector::regFunLst] && [llength $regFunLst] ]} { - array set regFun $regFunLst - regsub -all ,nameGui \ - [array names regFun *,nameGui] "" lstFun - foreach idf [lsort -integer $lstFun] { - set typeGui [split $regFun($idf,typeGui) .] - switch [lindex $typeGui 0] { - Ite - Set { - if {[lindex $typeGui 1] eq $gra} { - $data_menu($gra,Functions) add command -label [mc $regFun($idf,nameGui)]\ - -command [list ::TolInspector::CallUserFunction $gra $idf] - } - } - default { - } - } - } - } -} - -#///////////////////////////////////////////////////////////////////////////// -proc ::TolInspector::CallUserFunction {grammar idx} { -# -# PURPOSE: Para los tipos de funciones Ite y Set, muestra un dialogo que -# pide los -# -#///////////////////////////////////////////////////////////////////////////// - variable regFunLst - variable group_id - variable data - variable options_selected - - upvar \#0 ::TolInspector::options_selected($grammar) items_selected - #puts "CallUserFunction. grammar=$grammar, idx=$idx, items_selected=$items_selected" - - set all_objs [ list ] - foreach it $items_selected { - set tcl_ref [ lindex $it 0 ] - set obj_addr [ ::tol::info address $tcl_ref ] - lappend all_objs "GetObjectFromAddress(\"$obj_addr\")" - } - - if { [ llength $all_objs ] } { - incr group_id - array set regFun $regFunLst - set gui [bguifunction .t$group_id \ - -title $regFun($idx,nameGui) \ - -regpars $regFun($idx,parameters)] - set txtPars [join [$gui get values] ,] - if {$txtPars ne ""} { - set txtPars ",$txtPars" - } - destroy $gui - set typeGui [split $regFun($idx,typeGui) .] - switch [lindex $typeGui 0] { - Ite { - foreach obj $all_objs { - set cmd "$regFun($idx,typeOut) $regFun($idx,nameFun) ($obj $txtPars)" - #Tolcon_Trace "Ite.cmd=$cmd" - ::tol::console eval $cmd - ::TolConsole::SaveEval $cmd - } - } - Set { - set obj_args [join $all_objs ,] - set setCmd "SetOf[lindex $typeGui 1] ($obj_args)" - set cmd "$regFun($idx,typeOut) $regFun($idx,nameFun) ($setCmd $txtPars)" - #Tolcon_Trace "Set.cmd=$cmd" - ::tol::console eval $cmd - ::TolConsole::SaveEval $cmd - } - default { - } - } - ::TolInspector::UpdateConsoleObj - } -} - -namespace eval ::LoadStatus { - variable data -} - -#proc ::LoadStatus::Show {file} { -# -# set f [toplevel .topStatus] -# #wm protocol $path WM_DELETE_WINDOW [list ::Editor::OnDelete $this] -# # bind Destroy más abajo -# -# label $f.lfile -text $file -# # frame y label para barra de estado -# set data(sb,frame) [frame $f.fop -relief groove -bd 1 -height 7] -# set data(sb,objs) [label $f.fop.objs -relief groove -bd 1 -width 16] -# set data(sb,files) [label $f.fop.files -text [mc "Not Compiled"] \ -# -relief raised -bd 1 -width 16] -# set data(sb,time) [label $f.fop.time -bd 1 -width 14] -# set data(sb,rell) [label $f.fop.rell -relief groove -bd 1] -# -# -# # empaquetamos los label de estado -# pack $f.fop.objs $f.fop.files $f.fop.time -side left -# pack $f.fop.rell -expand true -fill x -# -# grid $f.lfile -sticky news -# grid $f.fop -sticky ews -# -# grid rowconfigure $f 1 -weight 1 -# grid columnconfigure $f 0 -weight 1 -# -#} -# -# -#proc ::LoadStatus::Hide {w} { -# -# Index: tolbase/lib/toltk/tolinspe__draw.tcl =================================================================== --- tolbase/lib/toltk/tolinspe__draw.tcl (revision 7a3f24e9fd698b7478644e5f73c3a75a53e4de3e) +++ tolbase/lib/toltk/tolinspe__draw.tcl (revision 7a3f24e9fd698b7478644e5f73c3a75a53e4de3e) @@ -0,0 +1,475 @@ + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::DrawSet {setref {type 0}} { +# +# PURPOSE: Graph a Set. For it it calls to a form for the selection of +# columns to graph +# +# PARAMETERS: +# setref -> Set to graph +# type -> 0 for custom association of data columns +# -> 1 for all data columns to first one +# -> 2 for all data columns to generic +# -> 3 for even data columns to odd ones +# +#///////////////////////////////////////////////////////////////////////////// + variable group_id + variable w_tabset + #puts "::TolInspector::DrawSet. setref: $setref" + incr group_id + if {[llength $setref] > 1} { + set name [lindex [::tol::info variable $setref] 1] + } else { + set name $setref + } + set cmd tablecmd$group_id + if {![catch {::tol::tableset create $cmd $setref}]} { + switch $type { + 0 { + set tl [::project::CreateForm \ + -width 500 -height 500 -type Graphs \ + -iniconfig Graph \ + -title [mc "Set graph: %s" $name] -helpkey "Tb4GraSet"] + $tl withdraw + set tlf [$tl getframe] + if {[set Instance [::SetGraphDialog::Init $tlf.g $cmd $setref]] != 0} { + bind $tlf.g +[list ::tol::tableset destroy $cmd] + pack $tlf.g -fill both -expand yes + $tl restore + update + # Esta opción se debe aplicar cuando el gráfico esté empacado + ::bayesGraph::GrapOptApplyAxisTicks $Instance ${Instance}::options gr,0 + } else { + destroy $tl + return + } + $tl bind [list $tl kill] + } + 1 - + 2 - + 3 { + # windows + set tl [::project::CreateForm \ + -title [mc "Set graph: %s" $name] -type Graphs -iniconfig SetGraph] + $tl withdraw + set tlf [$tl getframe] + set Instance [::SetGraphDialog::DrawSet $tlf.g $cmd $setref $type] + bind $tlf.g +[list ::tol::tableset destroy $cmd] + pack $tlf.g -fill both -expand yes + $tl restore + update + # Esta opción se debe aplicar cuando el gráfico esté empacado + ::bayesGraph::GrapOptApplyAxisTicks $Instance ${Instance}::options gr,0 + } + } + } else { + tk_messageBox -type ok -icon warning \ + -message [mc "Set is not graficable: %s" $::errorInfo] \ + -parent $w_tabset -title [mc "Warning"] + } +} + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::DrawMatrix {matref} { +# +# PURPOSE: draw the given matrix +# +# PARAMETERS: +# matref -> reference to the tol matrix +# +#///////////////////////////////////////////////////////////////////////////// + variable group_id + variable w_tabset + + incr group_id + if {[llength $matref] > 1} { + set name [lindex [::tol::info variable $matref] 1] + } else { + if { ([info exists obj]) } { + set name $obj + } + } + if { ([info exists name]) } { + set cmd tablecmd$group_id + if {![catch {::tol::tablematrix create $cmd $matref}]} { + set tl [::project::CreateForm \ + -width 500 -height 500 -type Graphs \ + -iniconfig Graph \ + -title [mc "Matrix graph: %s" $name] -helpkey "Tb4Gra"] + $tl withdraw + + set tlf [$tl getframe] + if {[set Instance [::SetGraphDialog::Init $tlf.g $cmd $matref]] != 0} { + bind $tlf.g +[list ::tol::tablematrix destroy $cmd] + pack $tlf.g -fill both -expand yes + $tl restore + update + # Esta opción se debe aplicar cuando el gráfico esté empacado + ::bayesGraph::GrapOptApplyAxisTicks $Instance ${Instance}::options gr,0 + } else { + destroy $tl + return + } + $tl bind [list $tl kill] + } else { + tk_messageBox -type ok -icon warning \ + -message [mc "Matrix is not graficable: %s" $::errorInfo] \ + -parent $w_tabset -title [mc "Warning"] + } + } +} + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::TableSet { set } { +#///////////////////////////////////////////////////////////////////////////// + variable w_tabset + variable group_id + + incr group_id + if {[llength $set] > 1} { + set nameSet [lindex [::tol::info variable $set] 1] + } else { + set nameSet $set + } + set setgrp group$group_id + if {![catch {::tol::tableset create $setgrp $set}]} { + # create + set tl [::project::CreateForm \ + -title "[mc "Set table"]: $nameSet" \ + -iniconfig SetTable \ + -type Tables -helpkey "Tb4Edt" + ] + set tlf [$tl getframe] + # config + btable $tlf.t -parent $tl \ + -posteditcmd [list ::TolConsole::TableRecentUpdate $tlf.t] \ + -iniconfig btable + $tlf.t fillSet $setgrp + pack $tlf.t -fill both -expand yes + bind $tlf.t +[list ::tol::tableset destroy $setgrp] + $tl bind [list $tl kill] + update + } else { + tk_messageBox -type ok -icon warning -message [mc "Set not tabulable"]\ + -parent $w_tabset -title [mc Warning] + } +} + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::TableMatrix { matrix } { +#///////////////////////////////////////////////////////////////////////////// + set mattb [::tol::matrix $matrix] + # create + set tl [::project::CreateForm \ + -title "[mc {Matrix table}]: [lindex $mattb 0]" \ + -iniconfig MatrixTable \ + -type Tables -helpkey "Tb4Edt" + ] + set tlf [$tl getframe] + # create matrix + btable $tlf.t -parent $tl \ + -posteditcmd [list ::TolConsole::TableRecentUpdate $tlf.t] \ + -iniconfig btable + $tlf.t fillMatrix $mattb + $tl bind [list $tl kill] + pack $tlf.t -fill both -expand yes + + #if {$grammar == "VMatrix"} { + #::tol::console stack release "zxw._.wxz" + #} +} + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::ExportBDTMatrix { matrix } { +#///////////////////////////////////////////////////////////////////////////// + variable group_id + + incr group_id + set tl [toplevel .top$group_id] + wm title $tl "ExportBDTMatrix" + + #pack $tl.t -fill both -expand yes +} + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::DrawSerie { } { +#///////////////////////////////////////////////////////////////////////////// + variable options_selected + upvar \#0 ::TolInspector::options_selected(Serie) series_selected + + #puts "DrawSerie: series_selected=$series_selected" + set series "" + foreach it $series_selected { + lappend series [lindex $it 0] + } + DrawSeries $series +} + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::DrawSeries { series {gcf ""}} { +#///////////////////////////////////////////////////////////////////////////// + variable group_id + + if { [llength $series] } { + incr group_id + # series + set sergrp group$group_id + set t0 [time { + eval "::tol::seriegrp create $sergrp $series" + }] + # name + set name [$sergrp serie 0 name] + if { [$sergrp serie size] > 1} { + set name ${name}... + } + # create + set t1 [time { + set tl [::project::CreateForm \ + -title [mc "Series graph: %s" $name] \ + -type Graphs \ + -iniconfig SeriesGraph \ + -width 900 -height 650 -helpkey "Tb4GraSer" + ]}] + set tlf [$tl getframe] + # configuration + set t2 [time { + set Instance [::SeriesGraph::Create $tlf.g $sergrp] + }] + #puts "t0 = $t0" + #puts "t1 = $t1" + #puts "t2 = $t2" + if { $gcf != "" } { + ::bayesGraph::LoadGCF $Instance $gcf + } + bind $tlf.g +[list ::tol::seriegrp destroy $sergrp] + pack $tlf.g -fill both -expand yes + $tl bind [list $tl kill] + update + # Esta opción se debe aplicar cuando el gráfico esté empacado + #::bayesGraph::GrapOptApplyAxisTicks $Instance ${Instance}::options gr,0 + } +} + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::DrawAutocorSerie { serie } { +#///////////////////////////////////////////////////////////////////////////// + variable group_id + + incr group_id + # title + + if {[llength $serie] > 1} { + set nameSerie [lindex [::tol::info variable $serie] 1] + } else { + set nameSerie $serie + } + # create + set tl [::project::CreateForm \ + -title "[mc "Autocorrelation graph"]: $nameSerie" \ + -iniconfig AutocorGraph \ + -type Graphs \ + -width 900 -height 650 -helpkey "Tb4GraAco" + ] + set tlf [$tl getframe] + # configuration + ::AutocorGraph::Create $tlf.g $serie + $tl bind "$tl kill; break" + pack $tlf.g -fill both -expand yes + update +} + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::TableSerie { } { +#///////////////////////////////////////////////////////////////////////////// + variable options_selected + variable group_id + upvar \#0 ::TolInspector::options_selected(Serie) series_selected + + set series "" + foreach it $series_selected { + lappend series [lindex $it 0] + } + + if { [llength $series] } { + incr group_id + + set sergrp group$group_id + eval "::tol::seriegrp create $sergrp $series" + + # create + set tl [::project::CreateForm \ + -title [mc "Time series table"] \ + -iniconfig SeriesTable \ + -type Tables -helpkey "Tb4Edt" + ] + set tlf [$tl getframe] + # configuration + btable $tlf.t -parent $tl \ + -posteditcmd [list ::TolConsole::TableRecentUpdate $tlf.t] \ + -iniconfig btable + $tlf.t fillSerie $sergrp + bind $tlf.t +[list ::tol::seriegrp destroy $sergrp] + pack $tlf.t -fill both -expand yes + $tl bind [list $tl kill] + update + } +} + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::TableAutocorSerie { serie } { +#///////////////////////////////////////////////////////////////////////////// + variable group_id + + incr group_id + # title + if {[llength $serie] > 1} { + set nameSerie [lindex [::tol::info variable $serie] 1] + } else { + set nameSerie $serie + } + # create + set tl [::project::CreateForm \ + -title "[mc "Autocorrelation table"]: $nameSerie" \ + -iniconfig AutocorGraphTable \ + -type Tables -helpkey "Tb4Edt" + ] + set tlf [$tl getframe] + # configuration + btable $tlf.t -parent $tl \ + -posteditcmd [list ::TolConsole::TableRecentUpdate $tlf.t] \ + -iniconfig btable + $tlf.t fillAutocor $serie "" + $tl bind [list $tl kill] + pack $tlf.t -fill both -expand yes +} + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::TableStatisticsSerie { } { +#///////////////////////////////////////////////////////////////////////////// + variable options_selected + variable group_id + upvar \#0 ::TolInspector::options_selected(Serie) series_selected + + set series "" + foreach it $series_selected { + lappend series [lindex $it 0] + } + + if { [llength $series] } { + incr group_id + + set sergrp group$group_id + eval "::tol::seriegrp create $sergrp $series" + # create + set tl [::project::CreateForm \ + -title [mc "Statistics table"] \ + -iniconfig StatisticsTable \ + -type Tables -helpkey "Tb4Edt" + ] + set tlf [$tl getframe] + # configuration + btable $tlf.t -parent $tl \ + -posteditcmd [list ::TolConsole::TableRecentUpdate $tlf.t] \ + -iniconfig btable + $tlf.t fillStatistics $sergrp + bind $tlf.t +[list ::tol::seriegrp destroy $sergrp] + $tl bind [list $tl kill] + pack $tlf.t -fill both -expand yes + } +} + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::ViewTimeSet { tms args } { +#///////////////////////////////////////////////////////////////////////////// + variable group_id + + incr group_id + + #puts "::TolInspector::ViewTimeSet $tms" + # args + array set opts [list \ + -title "[mc "TimeSet calendar"]: $tms" \ + -geometry {} + ] + array set opts $args + + # create + set tl [::project::CreateForm \ + -title $opts(-title) \ + -iniconfig Calendar \ + -type TimeSets -width 470 -height 345 -helpkey "Tb4Cal" + ] + # geometry + $tl setgeometry $opts(-geometry) + + set tlf [$tl getframe] + # configuration + set tmscmd tms$group_id + ::tol::timeset create $tmscmd $tms + ::CalendarTms::Create $tlf.t $tmscmd + bind $tlf.t +[list ::tol::timeset destroy $tmscmd] + bind $tl [list $tl kill] + pack $tlf.t -fill both -expand yes + + return $tl +} + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::ViewDefinition {name path grammar} { +#///////////////////////////////////////////////////////////////////////////// + variable w_tabset + if {$path == ""} { + tk_messageBox -type ok -icon warning\ + -message [mc "Object %1\$s is not defined in a tol file" $name]\ + -parent $w_tabset -title [mc Warning] + return + } + set ext [file extension $path] + switch -- $ext { + .tol - + .TOL { + set Instance [::Editor::Open $path] + update + if {[string equal $grammar "Code"] || + [string equal $grammar "Anything"]} { + append txtFind " " $name "( )*\\(" + } else { + #append txtFind $grammar "( )+" $name + append txtFind $name + } + #Me situo al principio del texto + set editor [::Editor::GetText $Instance] + tk::TextSetCursor $editor 1.0 + ::BayesText::FindShow $editor 1 $txtFind 1 + #::Editor::CmdFindNext $Instance $txtFind + } + .bst - + .BST - + .bdt - + .BDT { + # Igual luego se abre como tabla + ::Editor::Open $path + } + } +} + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::ViewFile {name} { +# +# PURPOSE: +# +# PARAMETERS: +# name -> cadena con el nombre de un archivo o el de una variable +# que hace referencia a un archivo +# +#///////////////////////////////////////////////////////////////////////////// + # En name puede venir el nombre de un archivo o el de una variable + # que hace referencia a un archivo. + #puts "ViewFile. name=$name" + if [file isfile $name] { + set path $name + } else { + set path [::tol::info path $name] + } + ::Editor::Open $path +} Index: tolbase/lib/toltk/tolinspe__main.tcl =================================================================== --- tolbase/lib/toltk/tolinspe__main.tcl (revision 7a3f24e9fd698b7478644e5f73c3a75a53e4de3e) +++ tolbase/lib/toltk/tolinspe__main.tcl (revision 7a3f24e9fd698b7478644e5f73c3a75a53e4de3e) @@ -0,0 +1,1014 @@ +#///////////////////////////////////////////////////////////////////////////// +# FILE : tolinspe.tcl +# PURPOSE : This file contains a namespace called TolInspector with its +# functions. Its for creating a the TOL object inspector and +# managing its events. +#///////////////////////////////////////////////////////////////////////////// + +package require bguifunction +package require snit +package require btable + +if { 0 && ![info exists toltk_script_path] } { + set toltk_script_path [file dirname [info script]] + source [file join $toltk_script_path init_toltk.tcl] +} + +if {"unix" eq $::tcl_platform(platform)} { + foreach "but units" [list 4 -5 5 5] { + set comm [string map "%d $units" { + %W yview scroll %d units + }] + bind TreeView <$but> $comm + } +} else { + bind TreeView { + %W yview scroll [expr int(-1*%D/36)] units + } +} +# +##///////////////////////////////////////////////////////////////////////////// +#proc dump { args } { +## +## PURPOSE: Auxiliary procedure to show a string +## +##///////////////////////////////////////////////////////////////////////////// +#puts $args +#} + +#///////////////////////////////////////////////////////////////////////////// +proc startupResources { } { +# +# PURPOSE: Establishes the preferences of the inspector +# +#///////////////////////////////////////////////////////////////////////////// + global tcl_platform + global toltk_options + DynamicHelp::configure -background #FFFFC0 + if {[string equal $tcl_platform(platform) "windows"]} { + set toltk_options(colors,SystemButtonFace) SystemButtonFace + set toltk_options(fonts,MenuNor) {Tahoma 8} + set toltk_options(fonts,Fixed) {{Courier New} 9} + set toltk_options(fonts,FixSmall) {{Courier New} 8} + set toltk_options(fonts,Title1) {Arial 9 bold} + set toltk_options(fonts,Label) {Arial 9} + set toltk_options(fonts,TxtSmall) {Arial 8} + set toltk_options(relief,ridge) ridge + } else { + set toltk_options(colors,SystemButtonFace) #d4d4d4 + set toltk_options(fonts,MenuNor) {-*-helvetica-medium-r} + set toltk_options(fonts,Fixed) {Courier 9} + set toltk_options(fonts,FixSmall) {-*-courier-small-r} + set toltk_options(fonts,Title1) {-*-helvetica-bold-r} + set toltk_options(fonts,Label) {-*-helvetica-medium-r} + set toltk_options(fonts,TxtSmall) {-*-helvetica-small-r} + set toltk_options(relief,ridge) raised + } + option add *background $toltk_options(colors,SystemButtonFace) user + option add *Label.font $toltk_options(fonts,Label) user + option add *Radiobutton.font $toltk_options(fonts,Label) user + option add *Checkbutton.font $toltk_options(fonts,Label) user + option add *Button.font $toltk_options(fonts,Label) user + option add *Menu.font $toltk_options(fonts,MenuNor) user + option add *TitleFrame.l.font $toltk_options(fonts,Title1) user + option add *Tabset.selectForeground black user + + option readfile [file join $::toltk_script_path toltk.rc] user +} + +#///////////////////////////////////////////////////////////////////////////// +namespace eval ::TolInspector { +# +# PURPOSE: The purpose of this namespace is creating a the TOL object +# inspector and managing its events. +# VARIABLES: +# data: +# regFunLst: List array with functions defined by user +# tolset: Name of the current TOL set variable +# tolindex: +# at_set: +# node_prefix: +# ht_tree: Tree widget containing the TOL objects (:blt::treeview) +# blt_tree: Tree widget containing the TOL objects (:blt::tree) +# w_tabset: Tabset widget containing trees of variables and functions +# ht_vars: Tree widget containing the tree of Variables +# (:blt::treeview) +# blt_vartree: Tree widget containing the tree of Variables (:blt::tree) +# data_menu: Array with data of menus +# group_id: +# ht_funcs: Tree widget containing the tree of Functions +# (:blt::treeview) +# blt_functree: Tree widget containing the tree of Functions (:blt::tree) +# item_data: Array to hold the full content & description of items +# item_id: Current index of item to insert in ht_* starting from 1 +# OnSelectItem: Command to invoke on SelectItem in ht_* +# OnBusyCmd: Command to invoke when busy +# SubTypeImgs: Images associated to types of set +# +#///////////////////////////////////////////////////////////////////////////// + variable data + + # List array with functions defined by user + variable regFunLst + + # name of the current TOL set variable. + variable tolset "" + variable tolindex "" + # estas variables desapareceran cuando ::tol::forallchild admita scripts + # completos y no solo nombres de proc + variable at_set + variable node_prefix + + variable iterSet "" + variable knownReference "" + + variable gra_parent "" + # tree widget containing the TOL objects. + variable ht_tree ;# is a ::blt::treeview + variable blt_tree ;# is a ::blt::tree + + # tabset widget containing trees of variables and functions + variable w_tabset + + # list widget containing the variables. It's the window of + # the tab Variable + variable ht_vars ;# is a ::blt::treeview + variable blt_vartree ;# is a ::blt::tree + + variable data_menu + variable group_id -1 + + # list widget containing the functions. It's the window of + # the tab Functions + variable ht_funcs ;# is a ::blt::treeview + variable blt_functree ;# is a ::blt::tree + + # array to hold the full content & description of items + variable item_data + + # current index of item to insert in ht_* starting from 1 + variable item_id + + # tell if we are processing a SelectSet event + + #variable selecting_set + #variable closing + + # command to invoke on SelectItem in ht_* + variable OnSelectItem + + # command to invoke when busy + variable OnBusyCmd "" + + # images associated to types of set. + variable SubTypeImgs { + GenericSet MODFile PRJFile DIRFile TOLFile + BDCFile BDTFile BSTFile BMTFile BSIFile TSIFile BMIFile + StructuredSet TableSet} + +} + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::SubTypeImage { idx } { +#///////////////////////////////////////////////////////////////////////////// + variable SubTypeImgs + + #Tolcon_Trace "SubTypeImage $idx = [lindex $SubTypeImgs $idx]" + ::Bitmap::get [lindex $SubTypeImgs $idx] +} + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::CreateColumns { ht } { +# +# PURPOSE: Creates the columns (index, name, content, path, description ) +# of the tree of variables or functions +# +# PARAMETERS: +# ht: path of ::blt::treeview of variables or ::blt::treeview of functions +# +#///////////////////////////////////////////////////////////////////////////// + # main column ==> Name + $ht column configure treeView -text [mc "Name"] -justify left \ + -bg white -activetitlebackground gray90 -pad 3 + # index column + $ht column insert 0 Index \ + -bg white -justify left -activetitlebackground gray90 + # columns Content Path & Description + #(pgea) se oculta la columna correspondiente a la referencia + $ht column insert end Content Description Path\ + -bg white -justify left -activetitlebackground gray90 -pad 3 + $ht column insert end Reference -hide yes + foreach c {Index Content Description Path} { + $ht column configure $c -text [mc "$c"] + } + # associates the command of order to each one of the titles of the + # columns of the trees + foreach column [$ht column names] { + $ht column configure $column \ + -command [list ::TolInspector::SortColumn $ht $column] + } +} + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::SortColumn {ht column} { +# +# PURPOSE: Associates the command of order to the title of a column of the +# tree of variables or the tree of functions +# +# PARAMETERS: +# ht: path of ::blt::treeview of variables or ::blt::treeview of +# functions +# column: name of the column of this tree +# +#///////////////////////////////////////////////////////////////////////////// + set old [$ht sort cget -column] + set decreasing 0 + if { "$old" == "$column" } { + set decreasing [$ht sort cget -decreasing] + set decreasing [expr !$decreasing] + } + $ht sort configure -decreasing $decreasing -column $column -mode integer + $ht configure -flat no + $ht sort auto yes + + blt::busy hold $ht + update + blt::busy release $ht +} + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::Create { w args } { +# +# PURPOSE: Creates the object inspector, that contains two panels with three +# treeviews and three trees. +# - One for the left side of the inspector (with grammars, +# included files, console objects and object's spool) +# - And two for the right one (one for variables tab and one for +# functions tab) +# +# PARAMETERS: +# w: path where tol inspector must be created +# args: list of pairs {-option value} with options for the inspector. +# -onselcmd Comand to execute when a node is selected +# -wleft relative weight of left pane +# -wrigth relative weight of rigth pane +# +#///////////////////////////////////////////////////////////////////////////// + global toltk_options + variable ht_tree + variable blt_tree + variable ht_vars + variable blt_vartree + variable data_menu + variable ht_funcs + variable blt_functree + variable w_tabset + variable OnSelectItem + variable OnBusyCmd "" + + # this should be used insted of a lot of scalar variables. + # but, what can we do now? + + variable widgets + variable data + + array set data { + pool,objects "" + } + + array set options { + -onselcmd "" + -wleft 3 + -wright 7 + } + array set options $args + + # initializes the command OnSelectItem to "" + set OnSelectItem $options(-onselcmd) + + #variable selecting_set 0 + #variable closing 0 + + #upvar \#0 ::TolTk::Images Images + + # creation of PANED WINDOW MAIN + set pwMain [PanedWindow $w -side bottom -pad 0 -width 4] + # creation of pane left and pane right + set paneLeft [$pwMain add -weight $options(-wleft)] + set paneRight [$pwMain add -weight $options(-wright)] + set widgets(panes,left) $paneLeft + set widgets(panes,right) $paneRight + + # when a panel is destroyed, the item 'geometry,side' of the array variable + # data gives the value of the width of panel 'side' (left or right) + bind $paneLeft { + namespace eval ::TolInspector { + variable data + variable widgets + set data(geometry,left) [winfo width $widgets(panes,left)] + } + } + bind $paneRight { + namespace eval ::TolInspector { + variable data + variable widgets + set data(geometry,right) [winfo width $widgets(panes,right)] + } + } + # bind for destruction of paned window main + bind $pwMain ::TolInspector::Destroy + + # creation of pane left with tree with the TOL OBJECTS + CreatePaneLeft $paneLeft + # creation of the right panel with TABSET of VARIABLES and FUNCTIONS + CreatePaneRight $paneRight + # creation of the menus + CreateMenus + # packing the panedwindowmain + pack $pwMain -fill both -expand yes + + # esto es para evitar que aparezca el icono open cuando + # relleno estando el mouse sobre ht_* + $ht_vars bind Entry "" + $ht_vars bind Entry "" + $ht_funcs bind Entry "" + $ht_funcs bind Entry "" +} + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::CreatePaneLeft { paneLeft } { +# +# PURPOSE: Creation of TREE LEFT with the TOL OBJECTS +# +# PARAMETERS: +# paneLeft: path of the pane of the left in TolInspector +# +#///////////////////////////////////////////////////////////////////////////// + global toltk_options + variable blt_tree + variable ht_tree + + # creation of the ScrolledWindow of the left side + set sw1 [ScrolledWindow $paneLeft.sw -ipad 0 -borderwidth 0 -scrollbar both ] + # creation of the left tree + set blt_tree [::blt::tree create tree$sw1.ht] + set ht_tree [::blt::treeview $sw1.ht -tree $blt_tree -bg white \ + -hideroot no -activeicons "" \ + -selectbackground gray75 -selectforeground black \ + -selectcommand ::TolInspector::SelectObject \ + -highlightthickness 0 -font $toltk_options(fonts,Label)] + # configuration of the left tree + $ht_tree configure \ + -closecommand "::TolInspector::CloseObject %#" \ + -opencommand "::TolInspector::OpenObject %#" + $ht_tree style configure text -bg white + $ht_tree column configure treeView -bg white + $ht_tree column insert end FileName -hide true + # creation of the root node "Tol Objects" + set img [::Bitmap::get Objects] + $ht_tree entry configure root -label [mc "Tol Objects"]\ + -icons [list $img $img] + + # creation of the node father "Grammars" + set img [::Bitmap::get Grammars] + set blt_idx [$blt_tree insert root -label "root-grammars"\ + -tags "root-grammars"] + $ht_tree entry configure $blt_idx -label [mc "Grammars"]\ + -icons [list $img $img] + # Inserts in the node of grammars a node by each grammar that exists in Tol + InsertGrammars + + # creation of the node father "Packages" + set img [::Bitmap::get "package"] + set blt_idx [$blt_tree insert root -label "root-packages"\ + -tags "root-packages"] + $ht_tree entry configure $blt_idx -label [mc "Packages"]\ + -icons [list $img $img] -button yes + + # creation of the node father "Included Files" + set img [::Bitmap::get "Files"] + set blt_idx [$blt_tree insert root -label "root-files" -tags "root-files"] + $ht_tree entry configure $blt_idx -label [mc "Included Files"] \ + -icons [list $img $img] -button yes + # creation of the node father "Console Objects" + set img [::Bitmap::get "Console"] + set blt_idx [$blt_tree insert root -label "root-console"\ + -tags "root-console"] + $ht_tree entry configure $blt_idx -label [mc "Console Objects"] \ + -icons [list $img $img] -button yes + # creation of the node father "Objects' Spool" + set img [::Bitmap::get "pool"] + set blt_idx [$blt_tree insert root -label "root-pool" -tags "root-pool"] + $ht_tree entry configure $blt_idx -label [mc "Objects' Spool"] \ + -icons [list $img $img] -button yes + # associates the tree to scrolled window + $sw1 setwidget $ht_tree + # packing + pack $sw1 -fill both -expand yes + # bind the focus on tree + bind $ht_tree "::focus $ht_tree" +} + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::CreatePaneRight { paneRight } { +# +# PURPOSE: Creation of the right pane with TABSET with VARIABLES and FUNCTIONS +# +# PARAMETERS: +# paneLeft: path of the pane of the right in TolInspector +# +#///////////////////////////////////////////////////////////////////////////// + global toltk_options + variable w_tabset + variable blt_vartree + variable ht_vars + variable blt_functree + variable ht_funcs + + # creates the tabset to display the variables & functions + #set w_tabset [::blt::tabset $paneRight.ts -relief flat\ + -bd 0 -outerpad 0 -tier 2 -slant none -textside top \ + -highlightthickness 0 -side left -rotate 90] + set w_tabset [::blt::tabset $paneRight.ts -relief flat\ + -bd 0 -outerpad 0 -tier 2 -slant right -textside right \ + -highlightthickness 0] + # creates the scrolled windows for each one of the tabs + set sw21 [ScrolledWindow $w_tabset.sw1] + set sw22 [ScrolledWindow $w_tabset.sw2] + # inserts in the tabset the tabs of functions and variables + $w_tabset insert end \ + Variables -text [mc Variables] -selectbackground \#d9d9d9 -bg gray75 \ + -image [::Bitmap::get Variables] -pady 0\ + Functions -text [mc Functions] -selectbackground \#d9d9d9 -bg gray75 \ + -image [::Bitmap::get Functions] -pady 0 + + # Creation of the right TREE RIGHT with VARIABLES + set blt_vartree [::blt::tree create tree$sw21.vars] + set ht_vars [::blt::treeview $sw21.vars -tree $blt_vartree -flat no\ + -bg white -hideroot yes -linewidth 0 -activeicons {}\ + -selectmode multiple\ + -selectbackground gray75 -selectforeground black \ + -highlightthickness 0 -font $toltk_options(fonts,Label)] + #tv_ordered_selection tvsel -tv $ht_vars + # configuration of the tree of variables + $ht_vars configure \ + -opencommand "::TolInspector::OpenVariable %#" \ + -selectcommand "::TolInspector::SelectItem $ht_vars" + $ht_vars style configure text -bg white + bind $ht_vars "::focus $ht_vars" + + # Creation of the right TREE RIGHT with FUNCTIONS + set blt_functree [::blt::tree create tree$sw22.funcs] + set ht_funcs [::blt::treeview $sw22.funcs -tree $blt_functree -flat no\ + -bg white -hideroot yes -linewidth 0 -activeicons {} \ + -selectmode multiple\ + -selectbackground gray75 -selectforeground black \ + -highlightthickness 0 -font $toltk_options(fonts,Label)] + # configuration of the tree of functions + $ht_funcs configure -selectcommand "::TolInspector::SelectItem $ht_funcs" + $ht_funcs style configure text -bg white + bind $ht_funcs "::focus $ht_funcs" + + # associates the trees to scrolled windows + $sw21 setwidget $ht_vars + $sw22 setwidget $ht_funcs + # configure the tabs + $w_tabset tab configure Variables -window $sw21 -fill both -padx 0 + $w_tabset tab configure Functions -window $sw22 -fill both -padx 0 + # create the columns of the trees of variables and functions + CreateColumns $ht_vars + CreateColumns $ht_funcs + # packing the tabset + pack $w_tabset -fill both -expand yes + $w_tabset tab configure Variables\ + -command "::TolInspector::SelectItem $ht_vars" + $w_tabset tab configure Functions\ + -command "::TolInspector::SelectItem $ht_funcs" +} + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::CreateMenus {} { +# +# PURPOSE: Create the menus of the trees +# +#///////////////////////////////////////////////////////////////////////////// + variable data_menu + variable ht_vars + variable ht_funcs + variable ht_tree + + set data_menu(main) [menu $ht_vars.m -tearoff 0] + set data_menu(Code,File) [menu $data_menu(main).mcof -tearoff 0] + set data_menu(Complex,File) [menu $data_menu(main).mcxf -tearoff 0] + set data_menu(Date,File) [menu $data_menu(main).mdaf -tearoff 0] + set data_menu(Matrix,File) [menu $data_menu(main).mmaf -tearoff 0] + set data_menu(VMatrix,File) [menu $data_menu(main).mvmf -tearoff 0] + set data_menu(Polyn,File) [menu $data_menu(main).mpof -tearoff 0] + set data_menu(Ratio,File) [menu $data_menu(main).mraf -tearoff 0] + set data_menu(Real,File) [menu $data_menu(main).mref -tearoff 0] + set data_menu(Serie,File) [menu $data_menu(main).msef -tearoff 0] + set data_menu(Set,File) [menu $data_menu(main).mstf -tearoff 0] + set data_menu(File,File) [menu $data_menu(main).mfif -tearoff 0] + set data_menu(Anything,File) [menu $data_menu(main).mspf -tearoff 0] + set data_menu(Text,File) [menu $data_menu(main).mtef -tearoff 0] + set data_menu(TimeSet,File) [menu $data_menu(main).mtif -tearoff 0] + set data_menu(NameBlock,File) [menu $data_menu(main).mnbf -tearoff 0] + + set data_menu(Code,Functions) [menu $data_menu(main).mcofu -tearoff 0] + set data_menu(Complex,Functions) [menu $data_menu(main).mcxfu -tearoff 0] + set data_menu(Date,Functions) [menu $data_menu(main).mdafu -tearoff 0] + set data_menu(Matrix,Functions) [menu $data_menu(main).mmafu -tearoff 0] + set data_menu(VMatrix,Functions) [menu $data_menu(main).mvmfu -tearoff 0] + set data_menu(Polyn,Functions) [menu $data_menu(main).mpofu -tearoff 0] + set data_menu(Ratio,Functions) [menu $data_menu(main).mrafu -tearoff 0] + set data_menu(Real,Functions) [menu $data_menu(main).mrefu -tearoff 0] + set data_menu(Serie,Functions) [menu $data_menu(main).msefu -tearoff 0] + set data_menu(Set,Functions) [menu $data_menu(main).mstfu -tearoff 0] + set data_menu(File,Functions) [menu $data_menu(main).mfifu -tearoff 0] + set data_menu(Anything,Functions) [menu $data_menu(main).mspfu -tearoff 0] + set data_menu(Text,Functions) [menu $data_menu(main).mtefu -tearoff 0] + set data_menu(TimeSet,Functions) [menu $data_menu(main).mtifu -tearoff 0] + set data_menu(NameBlock,Functions) [menu $data_menu(main).mnbfu -tearoff 0] + + set data_menu(Matrix,Table) [menu $data_menu(main).mmat -tearoff 0] + set data_menu(Matrix,Export) [menu $data_menu(main).mmae -tearoff 0] + set data_menu(Matrix,Draw) [menu $data_menu(main).mmac -tearoff 0] + set data_menu(Matrix,Export,BDT) [menu $data_menu(main).mmaebdt -tearoff 0] + set data_menu(Serie,DrawAutocor) [menu $data_menu(main).mseda -tearoff 0] + set data_menu(Serie,TableAutocor) [menu $data_menu(main).mseta -tearoff 0] + set data_menu(Set,Table) [menu $data_menu(main).mstt -tearoff 0] + set data_menu(Set,Table2) [menu $data_menu(main).mstt2 -tearoff 0] + set data_menu(Set,Draw) [menu $data_menu(main).mstd -tearoff 0] + set data_menu(Set,Draw,Special) [menu $data_menu(main).mstds -tearoff 0] + set data_menu(Set,Draw,Special,M) [menu $data_menu(main).mstdsm -tearoff 0] + set data_menu(File,View) [menu $data_menu(main).mfiv -tearoff 0] + set data_menu(File,Decompile) [menu $data_menu(main).mfid -tearoff 0] + set data_menu(TimeSet,View) [menu $data_menu(main).mtiv -tearoff 0] + #$ht_vars bind Entry +[$ht_vars bind Entry ] + + # composes the menus for each one of the trees, depending the node + # that is selected + $ht_vars bind all +[list ::TolInspector::PostVariable %X %Y] + $ht_funcs bind all +[list ::TolInspector::PostFunction %X %Y] + $ht_tree bind all +[list ::TolInspector::PostTree %X %Y] +} + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::GetWeight { pane } { +# +# PURPOSE: Set data(geometry,$pane) to the value of the current geometry +# of the pane +# +# PARAMETERS: +# pane -> string with a value "left" or "right" for each one of panels +# +#///////////////////////////////////////////////////////////////////////////// + variable widgets + variable data + + if {[winfo exists $widgets(panes,$pane)]} { + set data(geometry,$pane) [winfo width $widgets(panes,$pane)] + } + set data(geometry,$pane) +} + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::Destroy { } { +# +# PURPOSE: Destroys the three trees of TolInspector and array with full +# content & description of items +# +#///////////////////////////////////////////////////////////////////////////// + variable blt_tree + variable blt_vartree + variable blt_functree + variable item_data + + ::blt::tree destroy $blt_tree + ::blt::tree destroy $blt_vartree + ::blt::tree destroy $blt_functree + unset item_data +} + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::OneLine { str } { +# +# PURPOSE: Gives a string with carriage returns \n and return this string +# until the first carriage return that appears after a word, +# replacing the rest by ... if some word existed after that carriage +# return +# Examples: the str "a\n b c" returns "a..." +# "\n \n a\n b" returns "a..." +# "\n \n a\n" returns "a" +# PARAMETERS: +# str -> string with \n +# +#///////////////////////////////////////////////////////////////////////////// + set str [string trim $str] + set lnidx [string first "\n" $str] + if { $lnidx != -1 } { + if { [incr lnidx -1] > 0 } { + return "[string range $str 0 $lnidx]..." + } else { + return "..." + } + } + set str +} + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::TrimContent { grammar content } { +#///////////////////////////////////////////////////////////////////////////// + if { [string equal "Real" $grammar] } { + return [::TolConsole::Format $content] + } else { + if { [string equal \"\n\" $content] } { + set content {"\n"} + } + return [OneLine $content] + set content [string trim $content] + set lnidx [string first "\n" $content] + if { $lnidx != -1 } { + if { [incr lnidx -1] > 0 } { + return "[string range $content 0 $lnidx]..." + } else { + return "..." + } + } + set content + } +} + +#>> [tolinspe_wtree1.tcl] +#>> proc ::TolInspector::_InsertChild +#>> proc ::TolInspector::InsertChild +#>> proc ::TolInspector::Insert_HTItem +#>> proc ::TolInspector::ClearHiertables +#>> proc ::TolInspector::getPackageReference +#>> proc ::TolInspector::OpenObject +#>> proc ::TolInspector::InsertPackages +#>> proc ::TolInspector::InsertGrammars +#>> proc ::TolInspector::InsertFiles +#>> proc ::TolInspector::InsertConsoleObj +#>> proc ::TolInspector::InsertPoolObj +#>> proc ::TolInspector::InsertSubset + +proc ::TolInspector::FilterNameBlockMember { name } { + set st_reg [ regexp {(.+::)?(_)?(\.)?(.*)} $name => p1 p2 p3 p4] + if { !$st_reg } { + list -show 1 -fcolor "black" -name $name + } elseif { $p2 eq "_" } { + if { $p3 eq "." } { + if { [string match {autodoc.member.*} $p4] } { + # es un elemento de autodocumentacion y no se muestra + list -show 0 + } { + # es un miembro de solo lectura + list -show 1 -fcolor "gray50" -name "_.$p4" + } + } else { + # es un miembro oculto, + set showPrivate [ Tol_GetViewPrivateMembers ] + list -show $showPrivate -fcolor "gray75" -name "_$p4" + } + } else { + list -show 1 -fcolor "black" -name $p4 + } +} + +#>> [tolinspe__wtree2.tcl] +#>> proc ::TolInspector::ClearConsoleObj +#>> proc ::TolInspector::ClearConsoleObjSel +#>> proc ::TolInspector::UpdateFileRoot +#>> proc ::TolInspector::UpdateConsoleObj +#>> proc ::TolInspector::UpdatePoolObj + +#>> [tolinspe_wtree1.tcl] +#>> proc ::TolInspector::SelectObject +#>> proc ::TolInspector::SelectFileRoot +#>> proc ::TolInspector::SelectConsoleRoot +#>> proc ::TolInspector::SelectPoolRoot +#>> proc ::TolInspector::SelectGrammar +#>> proc ::TolInspector::SelectSet + +proc ::TolInspector::GetParentGrammar { set_ref } { + set root [ lindex $set_ref 0 ] + set L [ llength $set_ref ] + if { ( $root eq "File" && $L <= 2 ) } { + set root + } else { + lindex [ tol::info var $set_ref ] 0 + } +} + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::HasSubset { args } { +#///////////////////////////////////////////////////////////////////////////// + if { [string equal [lindex $args 0] "Set"] } { + variable has_button 1 + return 0 + } + return 1 +} + +#>> [tolinspe_wtree1.tcl] +#>> proc ::TolInspector::CloseObject +#>> proc ::TolInspector::OpenVariable +#>> proc ::TolInspector::SelectItem +#>> proc ::TolInspector::FillText + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::GetItemName { prefix idx_list } { +#///////////////////////////////////////////////////////////////////////////// + set node_id $prefix + foreach id $idx_list { + append node_id "-$id" + } + set node_id +} + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::OnBusy { cmd } { +#///////////////////////////////////////////////////////////////////////////// + variable OnBusyCmd $cmd +} + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::Busy { } { +#///////////////////////////////////////////////////////////////////////////// + variable OnBusyCmd + variable ht_tree + variable ht_vars + + $ht_tree configure -cursor watch + $ht_vars configure -cursor watch + if { [string length $OnBusyCmd] } { + eval $OnBusyCmd 1 + } +} + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::NotBusy { } { +#///////////////////////////////////////////////////////////////////////////// + variable OnBusyCmd + variable ht_tree + variable ht_vars + + $ht_tree configure -cursor "" + $ht_vars configure -cursor "" + + if { [string length $OnBusyCmd] } { + eval $OnBusyCmd 0 + } +} + +#>> [tolinspe__tolgui.tcl] +#>> proc TclList2SetOfText +#>> proc Tol_* +#>> proc TolGui_* + +#>> [tolinspe__wtree2.tcl] +#>> proc ::TolInspector::PostVariable +#>> proc ::TolInspector::PostFunction +#>> proc ::TolInspector::PostTree +#>> proc ::TolInspector::RemoveFromSpool +#>> proc ::TolInspector::AddToSpool +#>> proc ::TolInspector::AddToEvalWindow +#>> proc ::TolInspector::SelectAll +#>> proc ::TolInspector::ToggleSelection + +#>> [tolinspe__draw.tcl] +#>> proc ::TolInspector::ExportBDTMatrix +#>> proc ::TolInspector::Draw* +#>> proc ::TolInspector::Table* +#>> proc ::TolInspector::View* + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::DecompileFile {name} { +# +# PURPOSE: +# +# PARAMETERS: +# name -> cadena con el nombre de un archivo o el de una variable +# que hace referencia a un archivo +# +# TODO: Actualmente en name solo puede llegar el nombre de un archivo +# +#///////////////////////////////////////////////////////////////////////////// + variable data + #puts "DECOMPILE 1.1, name=$name" + if {[file isfile $name]} { + set path $name + } else { + set path [::tol::info path $name] + } + #puts "DECOMPILE 1.2" + #Comprobar si el archivo ya está abierto y si es así poner que no está compilado + if [namespace exists ::Editor] { + foreach ins [namespace children ::Editor] { + upvar \#0 ${ins}::data dataEd + if [string equal $dataEd(nameFile) $path] { + set dataEd(isCompiled) 0 + } + } + } + #puts "DECOMPILE 1.3" + #Quitar del spool todos los objetos provenientes de este archivo + + foreach _obj $data(pool,objects) { + array set obj $_obj + #Tolcon_Trace "REFERENCIA: $obj(reference)" + if {[string equal [lindex $obj(reference) 0] $path]} { + set idx [lsearch $data(pool,objects) $_obj] + set data(pool,objects) [lreplace $data(pool,objects) $idx $idx] + } + } + # https://www.tol-project.org/ticket/1483 + catch { + ::tol::decompile $path + } + ::TolInspector::UpdateFileRoot +} + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::ReadUserFunctions {} { +# +# PURPOSE: Recorre el set global que tiene la definicion de funciones y va +# guardando esa informacion en arrays para almacenarla finalmente en +# regFunLst +# +#///////////////////////////////////////////////////////////////////////////// + variable regFunLst + + #Set global que tiene la definicion de funciones + set obj GuiFunction + + if { [llength [set infAry [TclInfoVar Set $obj]] ] } { + #Tolcon_Trace "ReadUserFunctions: infAry = $infAry" + array set info $infAry + set nFun [lindex $info(CONTENT) 0] + #Tolcon_Trace "Numero de funciones =$nFun" + for {set idf 1} {$idf <= $nFun} {incr idf} { + array set ifNameFun [TclInfoRef [list Set $obj $idf 1]] + array set ifNameGui [TclInfoRef [list Set $obj $idf 2]] + array set ifTypeGui [TclInfoRef [list Set $obj $idf 3]] + array set ifTypeOut [TclInfoRef [list Set $obj $idf 4]] + array set ifParams [TclInfoRef [list Set $obj $idf 5]] + #Hago lindex $a(CONTENT) 0 para quitar las comillas + set regFun($idf,nameFun) [lindex $ifNameFun(CONTENT) 0] + set regFun($idf,nameGui) [lindex $ifNameGui(CONTENT) 0] + set regFun($idf,typeGui) [lindex $ifTypeGui(CONTENT) 0] + set regFun($idf,typeOut) [lindex $ifTypeOut(CONTENT) 0] + set nPar [lindex $ifParams(CONTENT) 0] + #Tolcon_Trace "Numero de parametros =$nPar" + for {set idp 1} {$idp <= $nPar} {incr idp} { + array set ipNameGui [TclInfoRef [list Set $obj $idf 5 $idp 1]] + array set ipTypePar [TclInfoRef [list Set $obj $idf 5 $idp 2]] + array set ipTypeSel [TclInfoRef [list Set $obj $idf 5 $idp 3]] + array set ipListVal [TclInfoRef [list Set $obj $idf 5 $idp 4]] + set regPar($idp,nameGui) [lindex $ipNameGui(CONTENT) 0] + set regPar($idp,typePar) [lindex $ipTypePar(CONTENT) 0] + set regPar($idp,typeSel) $ipTypeSel(CONTENT) + set nVal [lindex $ipListVal(CONTENT) 0] + #Tolcon_Trace "nVal=$nVal" + set lstVal "" + for {set idv 1} {$idv <= $nVal} {incr idv} { + array set iVal [TclInfoRef [list Set $obj $idf 5 $idp 4 $idv]] + lappend lstVal [lindex $iVal(CONTENT) 0] + } + set regPar($idp,lstVal) $lstVal + } + set regFun($idf,parameters) [array get regPar] + array unset regPar + #parray regFun + } + set regFunLst [array get regFun] + } else { + set regFunLst "" + } +} + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::ShowMenuUserFunc {gra} { +# +# PURPOSE: Muestra un menu contextual que... +# +#///////////////////////////////////////////////////////////////////////////// + variable data_menu + variable regFunLst + + #puts "ShowMenuUserFunc: gra=$gra" + if {[expr [info exist ::TolInspector::regFunLst] && [llength $regFunLst] ]} { + array set regFun $regFunLst + regsub -all ,nameGui \ + [array names regFun *,nameGui] "" lstFun + foreach idf [lsort -integer $lstFun] { + set typeGui [split $regFun($idf,typeGui) .] + switch [lindex $typeGui 0] { + Ite - Set { + if {[lindex $typeGui 1] eq $gra} { + $data_menu($gra,Functions) add command -label [mc $regFun($idf,nameGui)]\ + -command [list ::TolInspector::CallUserFunction $gra $idf] + } + } + default { + } + } + } + } +} + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::CallUserFunction {grammar idx} { +# +# PURPOSE: Para los tipos de funciones Ite y Set, muestra un dialogo que +# pide los +# +#///////////////////////////////////////////////////////////////////////////// + variable regFunLst + variable group_id + variable data + variable options_selected + + upvar \#0 ::TolInspector::options_selected($grammar) items_selected + #puts "CallUserFunction. grammar=$grammar, idx=$idx, items_selected=$items_selected" + + set all_objs [ list ] + foreach it $items_selected { + set tcl_ref [ lindex $it 0 ] + set obj_addr [ ::tol::info address $tcl_ref ] + lappend all_objs "GetObjectFromAddress(\"$obj_addr\")" + } + + if { [ llength $all_objs ] } { + incr group_id + array set regFun $regFunLst + set gui [bguifunction .t$group_id \ + -title $regFun($idx,nameGui) \ + -regpars $regFun($idx,parameters)] + set txtPars [join [$gui get values] ,] + if {$txtPars ne ""} { + set txtPars ",$txtPars" + } + destroy $gui + set typeGui [split $regFun($idx,typeGui) .] + switch [lindex $typeGui 0] { + Ite { + foreach obj $all_objs { + set cmd "$regFun($idx,typeOut) $regFun($idx,nameFun) ($obj $txtPars)" + #Tolcon_Trace "Ite.cmd=$cmd" + ::tol::console eval $cmd + ::TolConsole::SaveEval $cmd + } + } + Set { + set obj_args [join $all_objs ,] + set setCmd "SetOf[lindex $typeGui 1] ($obj_args)" + set cmd "$regFun($idx,typeOut) $regFun($idx,nameFun) ($setCmd $txtPars)" + #Tolcon_Trace "Set.cmd=$cmd" + ::tol::console eval $cmd + ::TolConsole::SaveEval $cmd + } + default { + } + } + ::TolInspector::UpdateConsoleObj + } +} + +namespace eval ::LoadStatus { + variable data +} + +#proc ::LoadStatus::Show {file} { +# +# set f [toplevel .topStatus] +# #wm protocol $path WM_DELETE_WINDOW [list ::Editor::OnDelete $this] +# # bind Destroy más abajo +# +# label $f.lfile -text $file +# # frame y label para barra de estado +# set data(sb,frame) [frame $f.fop -relief groove -bd 1 -height 7] +# set data(sb,objs) [label $f.fop.objs -relief groove -bd 1 -width 16] +# set data(sb,files) [label $f.fop.files -text [mc "Not Compiled"] \ +# -relief raised -bd 1 -width 16] +# set data(sb,time) [label $f.fop.time -bd 1 -width 14] +# set data(sb,rell) [label $f.fop.rell -relief groove -bd 1] +# +# +# # empaquetamos los label de estado +# pack $f.fop.objs $f.fop.files $f.fop.time -side left +# pack $f.fop.rell -expand true -fill x +# +# grid $f.lfile -sticky news +# grid $f.fop -sticky ews +# +# grid rowconfigure $f 1 -weight 1 +# grid columnconfigure $f 0 -weight 1 +# +#} +# +# +#proc ::LoadStatus::Hide {w} { +# +# Index: tolbase/lib/toltk/tolinspe__tolgui.tcl =================================================================== --- tolbase/lib/toltk/tolinspe__tolgui.tcl (revision 7a3f24e9fd698b7478644e5f73c3a75a53e4de3e) +++ tolbase/lib/toltk/tolinspe__tolgui.tcl (revision 7a3f24e9fd698b7478644e5f73c3a75a53e4de3e) @@ -0,0 +1,308 @@ + +proc Tol_GetViewPrivateMembers { } { + set viewOpt 0 + catch { + # no funciona + tol::console eval { + Real __getViewPrivateMembers_tmp__ = + TolConfigManager::Config::Various::View::PrivateMembers; + } + set x [ lindex [ tol::info variable { Real __getViewPrivateMembers_tmp__ } ] 2 ] + tol::console stack release __getViewPrivateMembers_tmp__ + set viewOpt [ expr { int( $x ) } ] + + } msg + #puts "Tol_GetViewPrivateMembers: $msg" + return $viewOpt +} + +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" ) + } ] + set info [ tol::info variable {Real __gui_check__} ] + set x [ lindex $info 2 ] + tol::console stack release __gui_check__ + expr { round($x) } +} + +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 Tol_ClassOfFromReference { objReference } { + set addr [ ::tol::info address $objReference ] + return [ Tol_ClassOf $addr ] +} + +proc Tol_StructOf { obj_addr } { + set tolcode [ string map [ list %A $obj_addr ] { + Text { + Anything obj = GetObjectFromAddress( "%A" ); + // WriteLn( "Tol_StructOf " << Grammar( obj ) ); + Text If( Grammar( obj ) == "Set", StructName( obj ), "" ) + } + } ] + return [ lindex [ toltcl::eval $tolcode ] 0 ] +} + +proc Tol_StructOfFromReference { objReference } { + # WATCH!!!! + # when Tol_StructOfFromReference is invoken on {File xxx} xxx is + # decompiled!!!! + if { [ llength $objReference ] == 2 && + [ lindex $objReference 0 ] eq "File" } { + return "" + } + set addr [ ::tol::info address $objReference ] + return [ Tol_StructOf $addr ] +} + +#(pgea) nueva funcion para obtener la informacion de instancia +proc Tol_InstanceInfo { obj_addr } { + tol::console eval [ string map [ list %A $obj_addr ] { + Text __gui_instanceinfo__ = { + Anything __intance__ = GetObjectFromAddress("%A"); + Text If(ObjectExist("Code", "__intance__::_.get.autodoc.info"), + __intance__::_.get.autodoc.info(?), "") + } + } ] + set info [ tol::info variable {Text __gui_instanceinfo__} ] + set x [ string trim [ lindex $info 2 ] \" ] + tol::console stack release __gui_instanceinfo__ + set x +} + +#(pgea) nueva funcion para obtener la informacion de instancia +proc Tol_InstanceInfoFromReference { objReference } { + set addr [ ::tol::info address $objReference ] + return [ Tol_InstanceInfo $addr ] +} + +#(pgea) nueva funcion para obtener el contenido de la instancia +proc Tol_InstanceContent { obj_addr } { + tol::console eval [ string map [ list %A $obj_addr ] { + Text __gui_instancecontent__ = { + Anything __intance__ = GetObjectFromAddress("%A"); + Text If(ObjectExist("Code", "__intance__::_.get.autodoc.content"), + __intance__::_.get.autodoc.content(?), "") + } + } ] + set info [ tol::info variable {Text __gui_instancecontent__} ] + set x [ string trim [ lindex $info 2 ] \" ] + tol::console stack release __gui_instancecontent__ + set x +} + +#(pgea) nueva funcion para obtener el contenido de la instancia +proc Tol_InstanceContentFromReference { objReference } { + set addr [ ::tol::info address $objReference ] + return [ Tol_InstanceContent $addr ] +} + +proc TolGui_GetMenuEntries { selection idx } { + #puts "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 ] + if { [ Tol_ObjIsClassOf $obj_addr "GuiTools::@MenuDesc" ] } { + set class [ Tol_ClassOf $obj_addr ] + 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) ] + } + #puts "$menu_info" + set menu_info +} + +proc TolGui_StoreSetElementsInOZA { object } { + set saveIn [ tk_getSaveFile -defaultextension .oza \ + -parent . -title [ mc "Store OZA" ] \ + -filetypes {{oza {.oza}}} ] + + if { $saveIn ne "" } { + set addr [ tol::info address $object ] + set tolexpr [ string map [ list %a $addr %f $saveIn ] { + Real Ois.Store( GetObjectFromAddress( "%a" ), "%f" ); + } ] + toltcl::eval $tolexpr + } +} + +proc TolGui_StoreSelectionInOZA { selection } { + set saveIn [ tk_getSaveFile -defaultextension .oza \ + -parent . -title [ mc "Store OZA" ] \ + -filetypes {{oza {.oza}}} ] + if { $saveIn ne "" } { + set lst_addr {} + foreach r $selection { + set a [ tol::info address $r ] + lappend lst_addr \"$a\" + } + set set_addr "\[\[ [join $lst_addr ,] \]\]" + set tolexpr [ string map [ list %L $set_addr %f $saveIn ] { + Real { + Set items = EvalSet( %L, Anything( Text addr ) { + Anything GetObjectFromAddress( addr ) + } ); + Real Ois.Store( items, "%f" ) + } + } ] + toltcl::eval $tolexpr + } +} + +proc TolGui_InsertEntriesMatrixChart { mm selection } { + if { ![ llength $selection ] } { + return 0 + } + set lst_addr {} + foreach r $selection { + set a [ tol::info address $r ] + lappend lst_addr \"$a\" + } + set set_addr "\[\[ [join $lst_addr ,] \]\]" + set tolexpr [ string map [ list %L $set_addr ] { + Real { + Set all_mat = EvalSet( %L, Matrix( Text addr ) { + GetObjectFromAddress( addr ) + } ); + Real R = Rows( all_mat[1] ); + Set st = EvalSet( all_mat, Real( Matrix it ) { + Real EQ( R, Rows( it ) ) + } ); + Real BinGroup( "And", st ) + } + } ] + set couldChart [ toltcl::eval $tolexpr ] + if { $couldChart } { + $mm add command -label [ mc "Draw matrix selection (natural)" ] \ + -command [ list TolGui_ChartMatrix $selection ] + } +} + +proc TolGui_ChartMatrix { selection } { + set lst_addr {} + foreach r $selection { + set a [ tol::info address $r ] + lappend lst_addr \"$a\" + } + set set_addr "\[\[ [join $lst_addr ,] \]\]" + set tolexpr [ string map [ list %L $set_addr ] { + Real { + Set all_mat = EvalSet( %L, Matrix( Text addr ) { + GetObjectFromAddress( addr ) + } ); + Set names = Copy( Empty ); + Set For( 1, Card( all_mat ), Real( Real k ) { + Text _n = Name( all_mat[ k ] ); + Text n = If( _n == "", "unamed", _n ); + Set Append( names, If( Columns( all_mat[ k ] ) == 1, [[ n ]], { + Set For( 1, Columns( all_mat[ k ] ), Text( Real k ) { + Text n << "[" << k << "]" + } ) + } ) ); + Real 1 + } ); + Matrix groupMat = BinGroup( "|", all_mat ); + Text TclChartMatrix( groupMat, + SetOfSet ( + @TclArgSt("-title", "Matrix Chart" ), + @TclArgSt("-type" , "2" ), + @TclArgSt("-names", TxtListTcl(names) ) ) ) + } + } ] + toltcl::eval $tolexpr +} + +proc TolGui_InsertEntriesFromMenuManager { targetMenu selection } { + set addrList [ list ] + foreach obj_info $selection { + set tcl_ref [ lindex $obj_info 0 ] + lappend addrList [ ::tol::info address $tcl_ref ] + } + ::MenuManager::insertEntriesForSelection $targetMenu $addrList +} + +proc TolGui_GetObjMenu { obj_addr } { + set try [ catch { + tol::console eval [ string map [ list %A $obj_addr ] { + GuiTools::@MenuDesc __aux_menu__ = GetObjectFromAddress("%A"); + Set __gui_menu_entries__ = __aux_menu__::getMenuEntries(?) + } ] } msg ] + if { $try } { + puts "ERROR TolGui_GetObjMenu : $msg" + set result "" + } else { + set result [ TolObj2TclObj {Set __gui_menu_entries__} ] + } + tol::console stack release __aux_menu__ + tol::console stack release __gui_menu_entries__ + set result +} + +proc TolGui_InvokeMethod { method obj_addr } { + #puts "TolGui_InvokeMethod $method $obj_addr" + set try [ catch { + tol::console eval [ string map [ list %A $obj_addr %M $method ] { + NameBlock __aux_instance__ = GetObjectFromAddress("%A"); + Real __aux_result__ = __aux_instance__::%M(?) + } ] } msg ] + if { $try } { + puts "ERROR TolGui_InvokeMethod : $msg" + } + tol::console stack release __aux_instance__ + tol::console stack release __aux_result__ +} + +proc TclList2SetOfText { lst } { + set result [ list ] + foreach i $lst { + lappend result \"[string map {\" \\\"} $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__ = { + Set aux = EvalSet( %S, NameBlock( Text addr ) { + NameBlock GetObjectFromAddress( addr ) + } ); + Real %C::%F( aux ) + } + } ] } msg ] + if { $try } { + puts "ERROR TolGui_InvokeGroup : $msg" + } + tol::console stack release __aux_result__ +} Index: tolbase/lib/toltk/tolinspe__wtree1.tcl =================================================================== --- tolbase/lib/toltk/tolinspe__wtree1.tcl (revision 7a3f24e9fd698b7478644e5f73c3a75a53e4de3e) +++ tolbase/lib/toltk/tolinspe__wtree1.tcl (revision 7a3f24e9fd698b7478644e5f73c3a75a53e4de3e) @@ -0,0 +1,1166 @@ + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::_InsertChild { args } { +# +# PURPOSE: este proc es para ancapsular desc en una lista +# +#///////////////////////////////////////////////////////////////////////////// + eval InsertChild [lrange $args 0 3] [list [list [lindex $args 4]]] [lrange $args 5 end] +} + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::InsertChild { args } { +# +# PURPOSE: Inserts a node in the corresponding treeview of the right panel. +# +# PARAMETERS: +# args[0] -> grammar +# args[1] -> name +# args[2] -> content +# args[3] -> path +# args[4] -> desc +# Si grammar == "Code" +# args[5] -> ¿es una variable? +# Si grammar == "Set" || "NameBlock" +# args[5] -> indexes of the set +# args[6] -> is file? +# args[7] -> has subset? +# args[8] -> subtype +# args[end] -> "Reference {reference}" end > 4 +# +#///////////////////////////////////////////////////////////////////////////// + variable ht_vars + variable blt_vartree + variable ht_funcs + variable blt_functree + variable gra_parent + + #puts "InsertChild: args=$args [info level 1]" + set grammar [lindex $args 0] + set name [ lindex $args 1 ] + set content [lindex $args 2] + set path [lindex $args 3] + set desc [lindex [lindex $args 4] 0] + + + if {[llength [lindex $args end]] >= 2} { + #set ref [list [lindex [lindex $args end] 0] [lrange [lindex $args end] 1 end]] + set ref [concat [lindex [lindex $args end] 0] [lrange [lindex $args end] 1 end]] + } else { + set ref "" + } + #puts "InsertChild: ref=$ref" + switch $grammar { + Code { + set isvar [lindex $args 5] + if { [string equal $isvar "1"] } { + Insert_HTItem $ht_vars $blt_vartree $grammar $name $content $path $desc $ref + } else { + Insert_HTItem $ht_funcs $blt_functree $grammar $name $content $path $desc $ref + } + } + NameBlock - + Set { + #puts "HTItem, ref = '$ref' '$args'" + # args[5] is the index of the set object + # args[6] is the flag file + # args[8] is the subtype + Insert_HTItem $ht_vars $blt_vartree $grammar $name $content $path $desc \ + [lindex $args 5] [lindex $args 6] [lindex $args 8] $ref + } + default { + Insert_HTItem $ht_vars $blt_vartree $grammar $name $content $path $desc $ref + } + } +} + +# si grammar == "Set" +# args[0] -> indexes +# args[1] -> ¿is a file? +# args[2] -> subtype + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::Insert_HTItem {ht tree grammar name content path desc args} { +#///////////////////////////////////////////////////////////////////////////// + variable ht_tree + variable tolset + variable tolindex + variable iterSet + variable knownReference + variable node_prefix + variable item_data + variable item_id + variable gra_parent + + #upvar \#0 ::TolTk::Images Images + + #puts "ENTER: ::TolInspector::Insert_HTItem" + if { $knownReference eq "" } { + set objRef $iterSet + lappend objRef $item_id + } else { + #puts "knownReference = $knownReference" + set objRef $knownReference + } + + #puts "\tobjRef = $objRef" + if { $gra_parent eq "NameBlock" } { + array set info_member [ FilterNameBlockMember $name ] + if { !$info_member(-show) } { + incr item_id + return + } + set fcolor $info_member(-fcolor) + } else { + set fcolor "black" + } + + set brief_cont [TrimContent $grammar $content] + set brief_desc [TrimContent DONTCARE $desc] + #puts "Insert_HTItem: args=$args" + if {[llength [lindex $args end]] >= 2} { + set ref_value [lindex [lindex $args end] 1] + } elseif {[regexp -- "console" $node_prefix]} { + set ref_value [list Console] + eval lappend ref_value $tolindex $item_id + } else { + set ref_value "" + } + + #puts "Insert_HTItem: ref_value=$ref_value tolindex=$tolindex item_id=$item_id node_prefix=$node_prefix" + #puts "\ttolset=$tolset" + set data [list Index $item_id \ + Content $brief_cont \ + Path $path \ + Description $brief_desc \ + Reference $ref_value] + + if {$grammar eq "Set" || $grammar eq "NameBlock"} { + if {[string length $tolset] || [regexp "console" $node_prefix]} { + # OJO: si tolset == "" no implica que no estemos en un Set + # por ejemplo un Set de la consola. + set item [GetItemName $node_prefix [lindex $args 0]] + #Tolcon_Trace "InsertHTItem. item(if): $item" + } else { + switch [lindex [$ht_tree get -full anchor] end] { + root-files { + set item file$item_id + } + root-console { + set item console$item_id + } + root-pool { + set item pool$item_id + } + default { + set item item$item_id + } + } + } + # aqui hay que pedir el bitmap en funcion del subtype: args[2] + if {$grammar eq "Set"} { + #puts "*******Set $objRef *******" + set icon_grammar [SubTypeImage [lindex $args 2]] + set data [lreplace $data 9 9 $objRef] + } else { + #(pgea) se reemplaza el valor de la referencia en data + set data [lreplace $data 9 9 $objRef] + #(pgea) se utiliza la informacon de instancia + #puts "Tol_ClassOfFromReference $objRef" + set classOf [Tol_ClassOfFromReference $objRef] + #puts "Tol_InstanceContentFromReference $objRef" + set insCont [Tol_InstanceContentFromReference $objRef] + if {$insCont ne ""} { + set data [lreplace $data 3 3 [TrimContent $grammar $insCont]] + } elseif {$classOf ne ""} { + set data [lreplace $data 3 3 $classOf] + } + set objAddress [ tol::info address $objRef ] + set icon_grammar [ ::ImageManager::getIconForInstance $objAddress ] + } + } elseif { $grammar eq "Anything" } { + set item "item$item_id" + set anyType [ tol::info anything $objRef ] + set icon_grammar [ ::Bitmap::get $anyType ] + } else { + set item "item$item_id" + set icon_grammar [ ::Bitmap::get $grammar ] + } + set idnew [$tree insert 0 -label $item] + set label [OneLine $name] + if {$label eq ""} { + if {[set label $brief_desc] eq ""} { + set label " " + } + } + $ht entry configure $idnew -label $label \ + -icons [list $icon_grammar $icon_grammar] -data $data \ + -foreground $fcolor + set item_data($item_id) [list $content $desc $grammar] + incr item_id +} + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::ClearHiertables { } { +# +# PURPOSE: +# +#///////////////////////////////////////////////////////////////////////////// + variable w_tabset + variable ht_vars + variable ht_funcs + variable item_data + variable OnSelectItem + + $ht_vars entry delete root 0 end + $ht_funcs entry delete root 0 end + $ht_vars column configure Index -hide no + $ht_funcs column configure Index -hide no + catch { + unset item_data + } + $w_tabset tab configure Variables -text [mc Variables] -state normal + $w_tabset tab configure Functions -state normal + + if { [string length $OnSelectItem] } { + $OnSelectItem + } +} + +# este proc debe pasar a ser un getContainerReference +# +proc ::TolInspector::getPackageReference { treePath } { + variable ht_tree + + #puts "::TolInspector::getPackageReference $treePath" + catch { + set typeContainer "NameBlock" + set order [ lindex [ split [ lindex $treePath 2 ] "-" ] end ] + incr order -1 + #puts "path,2 = [ lindex $treePath 2 ]" + #puts "order = $order" + set idx [lindex [ $ht_tree entry children "root-packages"] $order] + set nameContainer [ $ht_tree entry cget $idx -label ] + #puts "en root-package:" + #puts "\torder=$order" + #puts "\tidx=$idx" + #puts "\tnameContainer=$nameContainer" + set container [ list $typeContainer $nameContainer ] + if { [ llength $treePath ] > 3 } { + foreach c [ lrange $treePath 3 end-1 ] { + set orderItem [ lindex [ split $c "-" ] end ] + lappend container $orderItem + } + set tolindex [ lindex [ split [ lindex $treePath end ] "-" ] end ] + } else { + set tolindex [ list ] + } + } msg + #puts "::TolInspector::getPackageReference: $msg" + #puts "::TolInspector::getPackageReference: [ list $container $tolindex ]" + return [ list $container $tolindex ] +} + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::OpenObject { index } { +# +# PURPOSE: Script called each time a node in ht_tree (left treeview) is +# opened. +# +# PARAMETERS: +# index : The id of the node opened +# +#///////////////////////////////////////////////////////////////////////////// + variable tolset + variable tolindex + variable iterSet + variable at_set + variable node_prefix + variable ht_tree + variable data + + #puts "OpenObject: index=$index" + set path [$ht_tree get -full $index] + #puts "path = $path" + if { $index } { + set parent1 [lindex $path 1] + if { [set ispackage [string equal $parent1 "root-packages"]] || + [set isfile [string equal $parent1 "root-files"]] || + [set isconsole [string equal $parent1 "root-console"]] || + [string equal $parent1 "root-pool"] } { + set lpath [llength $path] + #puts "lpath = $lpath" + if { $lpath == 2 } { + if { $ispackage } { + InsertPackages + } elseif { $isfile } { + InsertFiles + } elseif { $isconsole } { + InsertConsoleObj + } else { + InsertPoolObj + } + } else { + #puts "OpenObject: path = $path" + set leaf [lindex $path end] + set leaf_info [split $leaf "-"] + set node_prefix [lindex $leaf_info 0] + set _tolset $tolset + if { $parent1 eq "root-packages" } { + foreach {tolset tolindex} [ getPackageReference $path ] break + } elseif { [string equal $parent1 "root-pool"] } { + #Tolcon_Trace "OpenObject. tolset=$tolset" + set tolset $data(pool,reference,[lindex $leaf_info 0]) + #puts "OpenObject: Spool: tolset=$tolset, leaf_info=$leaf_info" + if { $lpath == 3 } { + set tolindex [lrange $tolset 1 end] + set tolset [lindex $tolset 0] + } else { + set tolindex [lrange $leaf_info 1 end] + if {[lindex $tolset 0] eq "Console"} { + set tolset [lindex $tolset 0] + } else { + set tolset [lrange $tolset 0 1] + } + #set tolindex [lrange $tolset 1 end] + #set tolset [lindex $tolset 0] + #lappend tolindex [lindex $leaf_info end] + } + #Tolcon_Trace "OpenObject. tolset=$tolset" + } elseif {[regexp -- "console(.+)" $node_prefix --> idx_con]} { + set tolset "Console" + #puts "OpenObject: Console: leaf_info = $leaf_info" + if {[llength $leaf_info] == 1} { + set tolindex $idx_con + } else { + #set tolindex [list $idx_con [lrange $leaf_info 1 end]] + set tolindex [lrange $leaf_info 1 end] + } + } else { + set idx [$ht_tree find -name $node_prefix] + array set aryData [$ht_tree entry cget $idx -data] + set tolset [list File $aryData(FileName)] + #set tolset [$ht_tree entry cget [$ht_tree find -name $node_prefix] -label] + if { $lpath == 3 } { + set tolindex "" + } else { + set tolindex [lrange $leaf_info 1 end] + } + } + Busy + set at_set $index + set iterSet [eval list $tolset $tolindex] + variable gra_parent [ GetParentGrammar $iterSet ] + ::tol::forallchild $iterSet ::TolInspector::InsertSubset + set tolset $_tolset + NotBusy + } + } + } +} + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::InsertPackages {} { +# +# PURPOSE: Inserts a node in ht_tree (left ::blt::treeview) for each TOL +# packages +# +#///////////////////////////////////////////////////////////////////////////// + variable ht_tree + #upvar \#0 ::TolTk::Images Images + + set order 1 + foreach pkg [::tol::info packages] { + # takes an icon with the same name that the grammar + set img [ ::Bitmap::get NameBlock ] + $ht_tree insert -at "root-packages" end package-$order -label $pkg\ + -icons [list $img $img] -button yes + incr order + } +} + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::InsertGrammars {} { +# +# PURPOSE: Inserts a node in ht_tree (left ::blt::treeview) for each TOL +# grammar +# +#///////////////////////////////////////////////////////////////////////////// + variable ht_tree + #upvar \#0 ::TolTk::Images Images + + set id 1 + foreach g [::tol::info grammars] { + # takes an icon with the same name that the grammar + set img [::Bitmap::get $g] + $ht_tree insert -at "root-grammars" end grammar-$id -label $g\ + -icons [list $img $img] + incr id + } +} + + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::InsertFiles { } { +# +# PURPOSE: Inserts a node in ht_tree (left treeview) for each Included file +# +#///////////////////////////////////////////////////////////////////////////// + variable ht_tree + variable blt_tree + + set index 1 + #set img [::Bitmap::get "File"] + foreach f [lreverse [::tol::info included]] { + set finfo [::tol::info included $f] + set button [lindex $finfo 3] + set subtype [lindex $finfo 4] + # tomar la imagen en funcion del subtype + set img [SubTypeImage $subtype] + set tag_file "file$index" + set blt_idx [$blt_tree insert "root-files" \ + -label $tag_file -tags $tag_file] + # Tail del fichero. Podría hacerse configurable por el usuario + set label [file tail $f] + $ht_tree entry configure $blt_idx -label $label\ + -icons [list $img $img] -button $button -data [list "FileName" $f] + incr index + } +} + + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::InsertConsoleObj { } { +# +# PURPOSE: Inserts a node in ht_tree (left treeview) for each Console object +# +#///////////////////////////////////////////////////////////////////////////// + variable ht_tree + variable has_button 0 + + set index 1 + foreach co [::tol::console stack list] { + set grammar [lindex $co 0] + if {$grammar eq "Set" || $grammar eq "NameBlock"} { + # SUBTYPE: icono en funcion de [lindex $co 7] + if {$grammar eq "Set"} { + set icon [SubTypeImage [lindex $co 7]] + } else { + set objRef [ list "Console" $index ] + set objAddress [ tol::info address $objRef ] + set icon [ ::ImageManager::getIconForInstance $objAddress ] + } + set name [lindex $co 1] + #tol::forallchild $name HasSubset + set has_button [lindex $co 6] + if {$name eq ""} { + if {[set name [TrimContent DONTCARE [lindex $co 4]]] eq ""} { + set name " " + } + } + $ht_tree insert -at root-console end "console$index" -label $name \ + -icons [list $icon $icon] -button $has_button -data [list "FileName" $index] + } + incr index + } +} + + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::InsertPoolObj { } { +# +# PURPOSE: Inserts a node in ht_tree (left treeview) for each object in Spool +# +#///////////////////////////////////////////////////////////////////////////// + variable data + variable ht_tree + array unset data pool,reference,* + set index 1 + + foreach _obj $data(pool,objects) { + #Tolcon_Trace "InsertPoolObj. _obj=$_obj" + array set obj $_obj + if { [string equal $obj(grammar) "Set"] || [string equal $obj(grammar) "NameBlock"] } { + #Si la referencia del objeto tiene espacios en la ruta, el + # llength me daría > 1, por eso añado la 2ª parte de la condicion + if { ([llength $obj(reference)] > 1) && \ + ![string equal $obj(reference) $obj(objName)]} { + set infoObj [::tol::info variable $obj(reference)] + } else { + if {[catch { set infoObj [concat [list "Set" $obj(reference)] \ + [::tol::info included $obj(reference)]] }]} { + set infoObj [concat [list "Set" $obj(reference)] \ + [::tol::info variable "Set" $obj(reference)]] + } else { + # Insertamos el 1 de isFile + set infoObj [linsert $infoObj 5 1] + } + } + #Tolcon_Trace "infoObj=$infoObj" + if {[set name [file tail [lindex $infoObj 1]]] eq ""} { + if {[set name [TrimContent DONTCARE [lindex $infoObj 4]]] eq ""} { + set name " " + } + } + set has_button [lindex $infoObj 6] + #set icon [SubTypeImage [lindex $infoObj 7]] + if {$obj(grammar) eq "Set"} { + set icon [SubTypeImage [lindex $infoObj 7]] + } else { + #puts "en pool = $obj(reference)" + set objAddress [ tol::info address $objRef ] + set icon [ ::ImageManager::getIconForInstance $objAddress ] + } + + $ht_tree insert -at root-pool end "pool$index" -label $name \ + -icon [list $icon $icon] -button $has_button + #Tolcon_Trace "InsertPoolObj. name=$name" + if { ([llength $obj(reference)] > 1) && \ + [string equal $obj(reference) $obj(objName)]} { + set obj(reference) [list $obj(reference)] + } + set data(pool,reference,pool$index) $obj(reference) + } + incr index + } +} + + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::InsertSubset { args } { +# +# PURPOSE: Inserts a node in ht_tree (left treeview) for each child of a Set +# +# PARAMETERS: +# args[0] -> grammar +# args[1] -> name +# args[2] -> content +# args[3] -> path +# args[4] -> desc +# Si grammar == "Set" +# args[5] -> indexes of the set +# args[6] -> is file? +# args[7] -> has subset? +# args[8] -> subtype +# +#///////////////////////////////////////////////////////////////////////////// + variable ht_tree + variable at_set + variable tolset + variable iterSet + variable node_prefix + variable has_button 0 + variable blt_tree + variable gra_parent + catch { + #puts "InsertSubset, args=$args" + set grammar [lindex $args 0] + if {$grammar eq "Set" || $grammar eq "NameBlock"} { + #puts "InsertSubset, args=$args" + if { $gra_parent eq "NameBlock" } { + array set info_member [ FilterNameBlockMember [ lindex $args 1 ] ] + if { !$info_member(-show) } { + return + } + set name $info_member(-name) + set fcolor $info_member(-fcolor) + } else { + set name [ lindex $args 1 ] + set fcolor "black" + } + set content [lindex $args 2] + # idx es el indice completo desde el Set root + set idx [lindex $args 5] + set isfile [lindex $args 6] + set has_button [lindex $args 7] + set subtype [lindex $args 8] + #tol::forallchild $tolset $idx HasSubset + if {$grammar eq "Set"} { + set icon [SubTypeImage $subtype] + } else { + set objRef $iterSet + lappend objRef [ lindex $idx end ] + set objAddress [ tol::info address $objRef ] + set icon [ ::ImageManager::getIconForInstance $objAddress ] + } + # Tail por si es un fichero. Podría hacerse configurable por el usuario + set label [file tail $name] + #puts [list InsertSubset, idx {lindex $args 5} = $idx] + set idnew [ $blt_tree insert $at_set \ + -label [ GetItemName $node_prefix $idx ] ] + + #puts "InsertSubset, node_prefix = $node_prefix" + #puts "InsertSubset, idnew = $idnew" + #puts "InsertSubset, -label = [GetItemName $node_prefix $idx]" + + if {$label eq ""} { + if {[set label [TrimContent DONTCARE [lindex $args 4]]] eq ""} { + set label " " + } + } + $ht_tree entry configure $idnew -label $label -button $has_button \ + -icons [list $icon $icon] -foreground $fcolor + } +} msg +#puts "InsertSubSet: $msg" +} + + + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::SelectObject { } { +# +# PURPOSE: Script called each time a node in ht_tree (left treeview) is +# selected. +# +#///////////////////////////////////////////////////////////////////////////// + + #Tolcon_Trace "LLAMADA A SELECTOBJECT" + variable w_tabset + variable ht_tree + #variable set_type "" + variable tolset + variable tolindex + #variable closing + variable node_prefix "" + variable data + variable knownReference "" + + set index [$ht_tree index anchor] + + if { ![string length $index] } { + ClearHiertables + return + } + ClearHiertables + + set path [ $ht_tree get -full $index ] + set tolset "" + if { $index } { + #puts "SelectObject index = $index" + #puts "SelectObject: full = $path" + set info_node [split [lindex $path end] "-"] ;# ojo si el path tiene - + set node_type [lindex $info_node 0] + set node_name [lindex $info_node 1] + #puts "SelectObject: info_node = $info_node" + } else { + set node_type root + set node_name root + } + + Busy + #puts "SelectObject: node_type = $node_type, node_name = $node_name" + switch -regexp $node_type { + root { + switch $node_name { + root - + grammars { + ClearHiertables + #$w_tabset tab configure Variables -state disabled + #$w_tabset tab configure Functions -state disabled + } + package { + puts "implementa el llenado del panel derecho" + } + files { + SelectFileRoot + } + console { + SelectConsoleRoot + } + pool { + SelectPoolRoot + } + } + } + grammar { + SelectGrammar + } + default { + set node_prefix $node_type + #puts "SelectObject: node_prefix = $node_prefix" + if { $node_type eq "package" } { + foreach {tolset tolindex} [ getPackageReference $path ] break + } elseif {[regexp -- "pool" $node_type]} { + set tolset $data(pool,reference,[lindex $node_type 0]) + #puts "SelectObject: Spool: tolset=$tolset, info_node=$info_node" + if { [llength $info_node] == 1 } { + set tolindex [lrange $tolset 1 end] + set tolset [lindex $tolset 0] + } else { + #set tolindex [lrange $tolset 1 end] + #set tolset [lindex $tolset 0] + #lappend tolindex [lindex $info_node end] + set tolindex [lrange $info_node 1 end] + if {[lindex $tolset 0] eq "Console"} { + set tolset [lindex $tolset 0] + } else { + set tolset [lrange $tolset 0 1] + } + } + } elseif {[regexp -- "console(.+)" $node_type --> idx_con]} { + #puts "SelectObject: Console: tolset=$tolset info_node=$info_node idx_con=$idx_con" + set tolset "Console" + #set idx [$ht_tree find -name $node_type] + #array set aryData [$ht_tree entry cget $idx -data] + #set tolindex [eval list $aryData(FileName) [lrange $info_node 1 end]] + if {[llength $info_node] == 1} { + set tolindex $idx_con + } else { + set tolindex [lrange $info_node 1 end] + #set tolindex [concat [list $idx_con] $tolindex] + } + } else { + set idx [$ht_tree find -name $node_type] + array set aryData [$ht_tree entry cget $idx -data] + #puts "SelectObject: FileName=$aryData(FileName) info_node=$info_node" + set tolset [list File $aryData(FileName)] + set tolindex [lrange $info_node 1 end] + #set tolindex [lrange $info_node 2 end] + } + #puts "SelectObject end: tolset=$tolset, tolindex=$tolindex" + SelectSet + } + } + NotBusy +} + + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::SelectFileRoot { } { +# +# PURPOSE: Script called each time 'Included Files' node in ht_tree is +# selected. Gets information about each node that must be in +# included files, and inserts it in the right treeview. +# +#///////////////////////////////////////////////////////////////////////////// + variable item_id 1 + variable w_tabset + variable knownReference "" + + ClearHiertables + $w_tabset tab configure Variables -text [mc Files] + # $w_tabset tab configure Functions -state disabled + $w_tabset select 0 + foreach f [lreverse [::tol::info included]] { + # this catch is needed because info include could return files not + # realy included. + if { [ catch { ::tol::info included $f } fi ] } continue + # tener en cuenta el subtype cuando lo retorne + set knownReference [ list "File" $f ] + InsertChild Set $f \ + [lindex $fi 0] [lindex $fi 1] [list [lindex $fi 2]] $item_id 1 [lindex $fi 3] [lindex $fi 4] + } +} + + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::SelectConsoleRoot { } { +# +# PURPOSE: Script called each time 'Console Objects' node in ht_tree is +# selected. Gets information about each node that must be in console, +# and inserts it in the right treeview. +# +#///////////////////////////////////////////////////////////////////////////// + variable w_tabset + variable ht_vars + variable ht_funcs + variable item_id 1 + variable iterSet "Console" + variable knownReference "" + + ClearHiertables +#(pgea) se quita la linea que oculta la columna del indice y que +#(pgea) el procedimimento anterior ClearHiertables muestra +# $ht_vars column configure Index -hide yes +# $w_tabset tab configure Functions -state disabled + + foreach co [::tol::console stack list] { + #puts "SelectConsoleRoot: co = $co" + set gra [lindex $co 0] + set name [lindex $co 1] + set cont [lindex $co 2] + set path [lindex $co 3] + set desc [lindex $co 4] + set knownReference [ list Console $item_id ] + switch [lindex $co 0 ] { + Code { + InsertChild $gra $name $cont $path [list $desc] 0 + } + NameBlock - + Set { + #puts "switch: SelectConsoleRoot $gra" + InsertChild $gra $name $cont $path [list $desc] \ + $item_id [lindex $co 5] [lindex $co 6] [lindex $co 7] \ + [list Reference [list "Console" $item_id]] + } + default { + InsertChild $gra $name $cont $path [list $desc] \ + [list Reference [list "Console" $item_id]] + } + } + } + set knownReference "" +} + + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::SelectPoolRoot { } { +# +# PURPOSE: Script called each time 'Spool Objects' node in ht_tree is +# selected. Gets information about each node that must be in pool, +# and inserts it in the right treeview. +# +#///////////////////////////////////////////////////////////////////////////// + variable w_tabset + variable ht_vars + variable data + variable item_id 1 + variable knownReference "" + + ClearHiertables + $ht_vars column configure Index -hide yes + + array unset data pool,variables,* + # Para cada uno de los objetos que debe haber en el spool + # busco la información del nodo y lo inserto en el treeview de la derecha + foreach _obj $data(pool,objects) { + array set obj $_obj + #Si la referencia del objeto tiene espacios en la ruta, el + # llength me daría > 1, por eso añado la 2ª parte de la condicion + #puts "SelectPoolRoot: obj(grammar)=$obj(grammar) obj(objName)=$obj(objName) obj(reference)=$obj(reference)" + if { ([llength $obj(reference)] > 1) && ![string equal $obj(reference) $obj(objName)]} { + if {$obj(grammar) eq "Code"} { + set infoObj [concat [list $obj(grammar) $obj(objName)] \ + [::tol::info function $obj(reference)]] + } else { + set infoObj [::tol::info variable $obj(reference)] + } + #Tolcon_Trace "tol info (var|function) reference" + } else { + if {[catch { set infoObj [concat [list "Set" $obj(reference)] \ + [::tol::info included $obj(reference)]] }]} { + if {$obj(grammar) eq "Code"} { + set infoObj [concat [list $obj(grammar) $obj(reference)] \ + [::tol::info function $obj(graApply) $obj(reference)]] + } else { + #set infoObj [concat [list $obj(grammar) $obj(reference)] \ + # [::tol::info variable $obj(grammar) $obj(reference)]] + set infoObj [::tol::info variable [list $obj(grammar) $obj(reference)]] + } + #Tolcon_Trace "tol info (var|function) Grammar nameGlobal" + } else { + # Insertamos el 1 de isFile + set infoObj [linsert $infoObj 5 1] + #Tolcon_Trace "tol info included" + } + } + #Tolcon_Trace "INFOOBJ: $infoObj" + set gra [lindex $infoObj 0] + set name [lindex $infoObj 1] + set cont [lindex $infoObj 2] + set path [lindex $infoObj 3] + set desc [lindex $infoObj 4] + set data(pool,variables,$item_id) $obj(reference) + + switch $gra { + Code { + InsertChild $gra $name $cont $path [list $desc] 0 "Reference $obj(reference)" + } + Set - + NameBlock { + set knownReference $obj(reference) + InsertChild $gra $name $cont $path [list $desc] \ + $item_id [lindex $infoObj 5] [lindex $infoObj 6] [lindex $infoObj 7] "Reference $obj(reference)" + set knownReference "" + } + default { + InsertChild $gra $name $cont $path [list $desc] "Reference $obj(reference)" + } + } + } +} + + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::SelectGrammar { } { +# +# PURPOSE: Script called each time a Grammar node in ht_tree is selected. Gets +# information about each var and function of this grammar, and +# inserts them in the right treeview. +# +#///////////////////////////////////////////////////////////////////////////// + variable w_tabset + variable ht_tree + variable ht_vars + variable ht_funcs + variable item_id 1 + variable OnSelectItem + variable knownReference + + set knownReference "" + ClearHiertables + $ht_vars column configure Index -hide yes + $ht_funcs column configure Index -hide yes + set grammar [$ht_tree entry cget anchor -label] + if { [string compare $grammar "Anything"] } { + if { [string length $OnSelectItem] } { + $OnSelectItem [::tol::info grammars $grammar] + } + foreach var [::tol::info variables $grammar] { + if {[catch { + set vinfo [::tol::info variables [list $grammar $var]] + } msg]} { + Tol_HciWriter "in ::TolInspector::SelectGrammar : $msg\n" + continue + } + if { [string equal $grammar "Code"] } { + #Tolcon_Trace "Code : -- $vinfo --" + InsertChild $grammar $var [lindex $vinfo 2] [lindex $vinfo 3] [list [lindex $vinfo 4]] 1 + } elseif { $grammar eq "Set" || $grammar eq "NameBlock" } { + #Tolcon_Trace "Set : -- $vinfo --" + set knownReference [ list $grammar $var ] + InsertChild $grammar $var [lindex $vinfo 2] [lindex $vinfo 3] [list [lindex $vinfo 4]] \ + $item_id [lindex $vinfo 5] [lindex $vinfo 6] [lindex $vinfo 7] + } else { + InsertChild $grammar $var [lindex $vinfo 2] [lindex $vinfo 3] [list [lindex $vinfo 4]] $item_id 0 + } + } + } else { +# $w_tabset tab configure Variables -state disabled +# $w_tabset select 1 + } + foreach fun [::tol::info functions $grammar] { + set finfo [::tol::info functions $grammar $fun] + InsertChild Code $fun [lindex $finfo 0] [lindex $finfo 1] [list [lindex $finfo 2]] 0 + } +} + + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::SelectSet { } { +# +# PURPOSE: Script called each time a Set node in ht_tree is selected. Gets +# information about each child of this set, and inserts it in the +# right treeview. +# +#///////////////////////////////////////////////////////////////////////////// + variable ht_tree + variable ht_vars + variable ht_funcs + + variable tolset + variable tolindex + variable iterSet + variable var_id 1 + variable fun_id 1 + variable item_id + #variable selecting_set + + # if { $selecting_set } { + #puts "eoooo ..." + # return + # } + ClearHiertables + # set selecting_set 1 + set item_id 1 + + #puts "SelectSet: tolset=$tolset tolindex=$tolindex" + set iterSet [eval list $tolset $tolindex] + variable gra_parent [ GetParentGrammar $iterSet ] + ::tol::forallchild $iterSet ::TolInspector::_InsertChild + # set selecting_set 0 +} + + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::CloseObject { index } { +# +# PURPOSE: Script called each time a node in ht_tree (left treeview) is +# closed. +# +# PARAMETERS: +# index : The id of the node closed +# +#///////////////////////////////////////////////////////////////////////////// + variable ht_tree + #variable closing 1 + set path [$ht_tree get -full $index] + if { $index } { + set parent1 [lindex $path 1] + if { [string equal $parent1 "root-packages"] || + [string equal $parent1 "root-files"] || + [string equal $parent1 "root-console"] || + [string equal $parent1 "root-pool"] } { + $ht_tree entry delete $index 0 end + } + } +} + + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::OpenVariable { index } { +# +# PURPOSE: ???? +# +# PARAMETERS: +# index -> +# +#///////////////////////////////////////////////////////////////////////////// + variable tolset ;# Name of the current TOL set variable + variable ht_vars ;# ::blt::treeview of variables + variable ht_tree ;# ::blt::treeview left + variable blt_tree ;# ::blt::tree left + variable item_data ;# Array to hold the full content & description of items + + if { ![string length $index] } { + return + } + set node_anchor [lindex [$ht_tree get -full anchor] end] + + set tree_index -1 + #puts "OpenVariable = $item_data([lindex [$ht_vars entry cget $index -data] end])" + if { ![regexp -- "grammar-" $node_anchor] } { + set grammar [lindex $item_data([lindex [$ht_vars entry cget $index -data] end]) 2] + if {$grammar eq "Set" || $grammar eq "NameBlock"} { + $ht_tree open anchor + #puts "full = [$ht_vars get -full $index]" + set local_name [lindex [$ht_vars get -full $index] end] + set idx_anchor [$ht_tree index anchor] + #puts "a buscar $local_name dentro de $idx_anchor" + if {[set tree_index [$blt_tree findchild $idx_anchor $local_name]] == -1} { + foreach idx [$ht_tree entry children anchor] { + if { [string equal $local_name [lindex [$ht_tree get -full $idx] end]] } { + set tree_index $idx + break + } + } + } + } + } + if { $tree_index != -1 } { + update + blt::tv::SetSelectionAnchor $ht_tree $tree_index + set blt::tv::scroll 1 + #$ht_tree selection clearall + #$ht_tree see $tree_index + #$ht_tree focus $tree_index + #$ht_tree selection set $tree_index + #$ht_tree selection anchor $tree_index + #set blt::Hiertable::scroll 1 + } +} + + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::SelectItem { ht } { +# +# PURPOSE: Procedure that is executed when the user selects an element of +# the trees of variables orfunctions. +# First it take all the arguments necessary of the node of tree to +# execute the procedure stored in the variable OnSelectItem, and +# later executes it passing those arguments. +# +# PARAMETERS: path of ht_* (::blt::treeview of variables or of functions) +# +#///////////////////////////////////////////////////////////////////////////// + # variable w_text ;# TODO: ???? + variable OnSelectItem ;#Command to invoke on SelectItem in ht_* + variable item_data ;# Array to hold the full content & description of items + + set entry [$ht index anchor] ;# id of entry selected + if { [string length $OnSelectItem] } { + # there are associated command + if { [string length $entry] } { + # almost one entry of ht_* selected + array set aryData [$ht entry cget $entry -data] + set name [$ht entry cget $entry -label] ;# name of item + set itemid $aryData(Index) ;# id of item + set path $aryData(Path) ;# path of file of item + #(pgea) se anyade la propiedad Reference + set objRef $aryData(Reference) ;# info of item + set full_data $item_data($itemid) ;# {value} {desc} {grammar} + set value [lindex $full_data 0] ;# value of item PE: + # Anything Field(Set s, Text nombre) + + if { [string equal \"\n\" $value] } { + # hasn't value + set value {"\n"} + } else { + set value [string trim $value] + } + set desc [string trim [lindex $full_data 1]] + set grammar [lindex $full_data 2] + set icon [lindex [$ht entry cget $entry -icons] 0] + #(pgea) lista de argumentos que recibe ::TolConsole::OnInfo + set args [list $icon $grammar $name $value $path $desc $objRef] + } else { + set args "" + } + eval "$OnSelectItem $args" + } + return +#;# TODO: ???? +# if { [string length $entry] } { +# FillText $ht $entry +# } else { +# $w_text delete 1.0 end +# } +} + +#///////////////////////////////////////////////////////////////////////////// +#(pgea) se usa? +proc ::TolInspector::FillText { ht entry } { +#///////////////////////////////////////////////////////////////////////////// + variable w_text + variable item_data + #upvar #0 ::TolTk::Images Images + + $w_text delete 1.0 end + array set aryData [$ht entry cget $entry -data] + set name [$ht entry cget $entry -label] + set itemid $aryData(Index) + set full_data $item_data($itemid) + + set value [lindex $full_data 0] + if { [string equal \"\n\" $value] } { + set value {"\n"} + } + set desc [string trim [lindex $full_data 1]] + set grammar [lindex $full_data 2] + set icon [lindex [$ht entry cget $entry -icons] 0] + foreach {prop val} [list "Grammar: " $grammar "Name: " $name "Value: " [string trim $value]] { + set idx_start [$w_text index "end -1 chars"] + $w_text insert end $prop + set idx_end [$w_text index "end -1 chars"] + $w_text tag add tagLabel $idx_start $idx_end + if {[string equal $prop "Grammar: "]} { + $w_text image create end -image $icon + $w_text insert end " " + } + $w_text insert end "$val\n" + $w_text tag add tagValue $idx_end [$w_text index "end -1 chars"] + } + $w_text tag configure tagLabel -font fnBold + $w_text tag configure tagValue -wrap none + if { [string length $desc] } { + set idx_start [$w_text index "end -1 chars"] + $w_text insert end "Description\n" + set idx_end [$w_text index "end -1 chars"] + $w_text tag add tagPropLabel $idx_start $idx_end + $w_text insert end $desc + $w_text tag add tagPropValue $idx_end [$w_text index "end -1 chars"] + $w_text tag configure tagPropLabel -font fnBold -underline 1 + $w_text tag configure tagPropValue -wrap word + } +} + +#proc ::TolInspector::GetIndexes { nodeid } { +# variable ht_tree +# # No se utiliza +# # name is prefix-i1-i2-i3-...-in +# +# if { $nodeid } { +# lrange [split [$ht_tree get $nodeid] "-"] 1 end +# } else list +#} Index: tolbase/lib/toltk/tolinspe__wtree2.tcl =================================================================== --- tolbase/lib/toltk/tolinspe__wtree2.tcl (revision 7a3f24e9fd698b7478644e5f73c3a75a53e4de3e) +++ tolbase/lib/toltk/tolinspe__wtree2.tcl (revision 7a3f24e9fd698b7478644e5f73c3a75a53e4de3e) @@ -0,0 +1,923 @@ + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::ClearConsoleObj { } { +#///////////////////////////////////////////////////////////////////////////// + variable ht_tree + variable data + + set idx_con [$ht_tree index root-console] + $ht_tree entry delete $idx_con 0 end + + #Quitamos del spool todos los objetos que provengan de la consola + foreach _obj $data(pool,objects) { + array set obj $_obj + if {[string equal $obj(origin) "root-console"]} { + set idx [lsearch $data(pool,objects) $_obj] + set data(pool,objects) [lreplace $data(pool,objects) $idx $idx] + } + } + UpdatePoolObj + #Finalmente limpiamos el stack de la consola de tol + ::tol::console stack release +} + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::ClearConsoleObjSel {ht} { +#///////////////////////////////////////////////////////////////////////////// + variable vars_selected + variable data + + foreach var $vars_selected { + set name [$ht entry cget $var -label] + #puts "name=$name" + #Quitamos del spool todos los objetos que provengan de la consola + foreach _obj $data(pool,objects) { + array set obj $_obj + #puts "_obj=$_obj" + if {[string equal $obj(origin) "root-console"] && [string equal $obj(objName) $name]} { + set idx [lsearch $data(pool,objects) $_obj] + set data(pool,objects) [lreplace $data(pool,objects) $idx $idx] + } + } + UpdatePoolObj + #Finalmente quitamos el objeto de la consola de tol + ::tol::console stack release $name + } + UpdateConsoleObj +} + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::UpdateFileRoot { } { +#///////////////////////////////////////////////////////////////////////////// + variable ht_tree + set open 0 + set idx_file [$ht_tree index root-files] + if { [$ht_tree entry isopen $idx_file] } { + $ht_tree close $idx_file + set open 1 + } + if { [$ht_tree index focus] == $idx_file } { + SelectObject + } + if $open { + $ht_tree open $idx_file + } +} + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::UpdateConsoleObj { } { +#///////////////////////////////////////////////////////////////////////////// + variable ht_tree + + set idx_con [$ht_tree index root-console] + if { [$ht_tree entry isopen $idx_con] } { + $ht_tree close $idx_con + } + $ht_tree selection anchor root-console + $ht_tree selection mark root-console + #Tolcon_Trace "Abierto el nodo root-console" + if { [$ht_tree index focus] == $idx_con } { + SelectObject + } +} + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::UpdatePoolObj { } { +#///////////////////////////////////////////////////////////////////////////// + variable ht_tree + + set idx_pool [$ht_tree index root-pool] + if { [$ht_tree entry isopen $idx_pool] } { + $ht_tree close $idx_pool + } + if { [$ht_tree index focus] == $idx_pool } { + SelectObject + } +} + + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::PostVariable { x y } { +# +# PURPOSE: Composes a popup menu for variables and displays it. Its composed +# depending on the node/s clicked by user. +# +# PARAMETERS: +# x -> x-coordinate where popup menu is drawn +# y -> y-coordinate where popup menu is drawn +# +#///////////////////////////////////////////////////////////////////////////// + variable data_menu + variable vars_selected + variable options_selected + variable ht_vars + variable ht_tree + variable item_data + variable data + + variable tolset + variable tolindex + + #User functions to contextual menu + ::TolInspector::ReadUserFunctions + + array unset options_selected + set all_objects {} + + foreach it [array names data_menu] { + $data_menu($it) delete 0 end + } + set InRootConsole [string equal [lindex [$ht_tree get -full anchor] end] "root-console"] + set InRootPool [string equal [lindex [$ht_tree get -full anchor] end] "root-pool"] + set InRootFiles [string equal [lindex [$ht_tree get -full anchor] end] "root-files"] + #puts "PostVariable: InRootConsole,InRootPool,InRootFiles = $InRootConsole,$InRootPool,$InRootFiles" + set node_act [$ht_vars index current] + if { [string length $node_act] } { + set vars_selected [$ht_vars curselection] + if { [lsearch $vars_selected $node_act] >= 0 } { + foreach var $vars_selected { + array set aryData [$ht_vars entry cget $var -data] + #puts "PostVariable: aryData = [array get aryData]" + set itemid $aryData(Index) + set path $aryData(Path) + set grammar [lindex $item_data($itemid) 2] + set objName [$ht_vars entry cget $var -label] + #puts "OBJECT=$objName, PATH=$path" + if { $InRootPool } { + set object $data(pool,variables,$itemid) + } else { + if {[llength $aryData(Reference)]} { + #set object [lindex $aryData(Reference) 0] + set object [lrange $aryData(Reference) 0 end] + } else { + if { [string length $tolset] } { + #set object [concat [list File $tolset] $tolindex $itemid] + set object [concat $tolset $tolindex $itemid] + #puts "tolset = $tolset" + } else { + if [llength $objName] { + set object [list $grammar $objName] + } else { + set object $objName + } + } + } + } + lappend all_objects $object + #puts "PostVariable: OBJECT=$object OBJNAME=$objName TOLSET=$tolset PATH=$path GRAMMAR=$grammar" + switch -- $grammar { + Code - + Complex - + Date - + Matrix - + VMatrix - + Polyn - + Ratio - + Real - + Serie - + Anything - + Text - + NameBlock - + TimeSet { + lappend options_selected($grammar) [list $object $objName $path] + } + Set { + # Si el objeto se da como referencia + if { [llength $object] > 1 } { + #puts "PostVariable: Set: object = $object" + if {$InRootFiles} { + set isFile 1 + } else { + set info [::tol::info var $object] + set isFile [expr [lindex $info 7] == 4] + } + #set desc [lindex $info 4] + } else { + if {[catch "::tol::info included $object" info]} { + set info [::tol::info var [list Set $objName]] + #set isFile [expr [lindex $info 5] == 4] + set isFile [expr [lindex $info 7] == 4] + #set desc [lindex $info 4] + } else { + #set info [::tol::info included $objName] + #set isFile [expr [lindex $info 4] == 4] + set isFile 1 + #set desc "" + } + } + if $isFile { + lappend options_selected(File) [list $object $objName $path] + } else { + lappend options_selected($grammar) [list $object $objName $path] + } + } + } + } + set grammar_selected [array names options_selected] + if { [llength $grammar_selected] } { + foreach grammar $grammar_selected { + switch -- $grammar { + VMatrix - + Matrix { + $data_menu(main) add cascade -label [mc "Export matrix"]\ + -menu $data_menu(Matrix,Export) + if {[llength $options_selected($grammar)] == 1} { + set object [lindex [lindex $options_selected($grammar) 0] 0] + $data_menu(main) add command -label [mc "Table matrix"] \ + -command [list ::TolInspector::TableMatrix $object] + $data_menu(Matrix,Export) add command -label "BDT" \ + -command [list ::TolInspector::ExportBDTMatrix $object] + $data_menu(main) add command -label [mc "Draw matrix"]... \ + -command [list ::TolInspector::DrawMatrix $object] + } else { + $data_menu(main) add cascade -label [mc "Table matrix"] \ + -menu $data_menu(Matrix,Table) + $data_menu(Matrix,Export) add cascade -label "BDT" \ + -menu $data_menu(Matrix,Export,BDT) + $data_menu(main) add cascade -label [mc "Draw matrix"]... \ + -menu $data_menu(Matrix,Draw) + foreach objInfo $options_selected(Matrix) { + $data_menu(Matrix,Table) add command -label [lindex $objInfo 1]\ + -command [list ::TolInspector::TableMatrix [lindex $objInfo 0]] + $data_menu(Matrix,Export,BDT) add command -label [lindex $objInfo 1]\ + -command [list ::TolInspector::ExportBDTMatrix [lindex $objInfo 0]] + $data_menu(Matrix,Draw) add command -label [lindex $objInfo 1] \ + -command [list ::TolInspector::DrawMatrix [lindex $objInfo 0]] + } + } + if { $grammar eq "Matrix" } { + set all_matrix {} + foreach m $options_selected(Matrix) { + lappend all_matrix [ lindex $m 0 ] + } + TolGui_InsertEntriesMatrixChart $data_menu(main) $all_matrix + } + } + Serie { + if {[llength $options_selected(Serie)] == 1} { + set lblSerie "serie" + } else { + set lblSerie "series" + } + $data_menu(main) add command -label [mc "Draw $lblSerie"]\ + -command ::TolInspector::DrawSerie + $data_menu(main) add command -label [mc "Table $lblSerie"]\ + -command ::TolInspector::TableSerie + if {[llength $options_selected(Serie)] == 1} { + set object [lindex [lindex $options_selected(Serie) 0] 0] + $data_menu(main) add command -label [mc "Draw autocorrelation"] \ + -command [list ::TolInspector::DrawAutocorSerie $object] + $data_menu(main) add command -label [mc "Table autocorrelation"] \ + -command [list ::TolInspector::TableAutocorSerie $object] + } else { + $data_menu(main) add cascade -label [mc "Draw autocorrelation"] \ + -menu $data_menu(Serie,DrawAutocor) + $data_menu(main) add cascade -label [mc "Table autocorrelation"] \ + -menu $data_menu(Serie,TableAutocor) + foreach objInfo $options_selected(Serie) { + $data_menu(Serie,DrawAutocor) add command -label [lindex $objInfo 1]\ + -command [list ::TolInspector::DrawAutocorSerie [lindex $objInfo 0]] + $data_menu(Serie,TableAutocor) add command -label [lindex $objInfo 1]\ + -command [list ::TolInspector::TableAutocorSerie [lindex $objInfo 0]] + } + } + $data_menu(main) add command -label [mc "Table statistics"]\ + -command ::TolInspector::TableStatisticsSerie + } + TimeSet { + if {[llength $options_selected(TimeSet)] == 1} { + set object [lindex [lindex $options_selected(TimeSet) 0] 0] + $data_menu(main) add command -label [mc "View timeset"] \ + -command [list ::TolInspector::ViewTimeSet $object] + } else { + $data_menu(main) add cascade -label [mc "View timeset"] \ + -menu $data_menu(TimeSet,View) + foreach objInfo $options_selected(TimeSet) { + $data_menu(TimeSet,View) add command -label [lindex $objInfo 1] \ + -command [list ::TolInspector::ViewTimeSet [lindex $objInfo 0]] + } + } + } + NameBlock { + # entradas desde MenuManager + if 0 { + TolGui_InsertEntriesFromMenuManager \ + $data_menu(main) \ + $options_selected(NameBlock) + } + # entradas desde @MenuDesc + # @MenuDesc sera reemplazado, ver https://www.tol-project.org/ticket/1372 + set sel_length [ llength $options_selected(NameBlock) ] + if { $sel_length } { + set idx_current [ lsearch $vars_selected $node_act ] + set all_nb_options \ + [ TolGui_GetMenuEntries \ + $options_selected(NameBlock) $idx_current ] + set num_options [ llength $all_nb_options ] + #puts "num_options = $num_options" + foreach mi $all_nb_options { + set _cname [ lindex $mi 0 ] + set cname [ string map [ list @ "" . _ ] $_cname ] + #puts "cname = $cname" + foreach { ninst obj_addr entries } [ lindex $mi 1 ] break + set instances [ lindex $mi 2 ] + if { $num_options > 1 } { + # creo el menu de la clase si no existe + set mclass $data_menu(main).cls$cname + if { ![ winfo exists $mclass ] } { + menu $mclass -tearoff 0 + } else { + $mclass delete 0 end + } + $data_menu(main) add cascade -label $cname -menu $mclass + set target_menu $mclass + } else { + set target_menu $data_menu(main) + } + foreach inst_entry $entries { + foreach { label single group } $inst_entry break + set opt_label \ + "$label [ expr { $sel_length>1 ? $ninst : {} } ]" + $target_menu add command -label $opt_label \ + -command [ list TolGui_InvokeMethod \ + $single $obj_addr ] + if { $group ne "" && [ llength $instances ] > 1 } { + # hay una funcion que se aplica a toda la seleccion + $target_menu add command -label "$label All" \ + -command [ list TolGui_InvokeGroup \ + $_cname $group $instances ] + } + } + } + } + } + Set { + if {[llength $options_selected(Set)] == 1} { + set object [lindex [lindex $options_selected(Set) 0] 0] + $data_menu(main) add command -label [mc "Table set"] \ + -command [list ::TolInspector::TableSet $object] + $data_menu(main) add command -label [mc "Draw set"] \ + -command [list ::TolInspector::DrawSet $object] + # menu special + $data_menu(main) add cascade -label [mc "Draw set special"] \ + -menu $data_menu(Set,Draw,Special) + $data_menu(Set,Draw,Special) add command \ + -label [mc SetGraphAllFirst] \ + -command [list ::TolInspector::DrawSet $object 1] + $data_menu(Set,Draw,Special) add command \ + -label [mc SetGraphAllGeneric] \ + -command [list ::TolInspector::DrawSet $object 2] + $data_menu(Set,Draw,Special) add command \ + -label [mc SetGraphEvenUneven] \ + -command [list ::TolInspector::DrawSet $object 3] + } else { + $data_menu(main) add cascade -label [mc "Table set"] \ + -menu $data_menu(Set,Table) + $data_menu(main) add cascade -label [mc "Draw set"] \ + -menu $data_menu(Set,Draw) + foreach objInfo $options_selected(Set) { + $data_menu(Set,Table) add command -label [lindex $objInfo 1] \ + -command [list ::TolInspector::TableSet [lindex $objInfo 0]] + $data_menu(Set,Draw) add command -label [lindex $objInfo 1] \ + -command [list ::TolInspector::DrawSet [lindex $objInfo 0]] + } + # menu special + set i 0 + $data_menu(main) add cascade -label [mc "Draw set special"] \ + -menu $data_menu(Set,Draw,Special,M) + foreach objInfo $options_selected(Set) { + # exists menu previus ? + if {[winfo exists $data_menu(Set,Draw,Special,M).setdrawspecialm$i]} { + destroy $data_menu(Set,Draw,Special,M).setdrawspecialm$i + } + set mn \ + [menu $data_menu(Set,Draw,Special,M).setdrawspecialm$i \ + -tearoff 0] + $data_menu(Set,Draw,Special,M) add cascade \ + -label [lindex $objInfo 1] -menu $mn + $mn add command -label [mc SetGraphAllFirst] \ + -command [list ::TolInspector::DrawSet [lindex $objInfo 0] 1] + $mn add command -label [mc SetGraphAllGeneric] \ + -command [list ::TolInspector::DrawSet [lindex $objInfo 0] 2] + $mn add command -label [mc SetGraphEvenUneven] \ + -command [list ::TolInspector::DrawSet [lindex $objInfo 0] 3] + incr i + } + } + } + File { + if {[llength $options_selected(File)] == 1} { + set objName [lindex [lindex $options_selected(File) 0] 1] + $data_menu(main) add command -label [mc "View file"] \ + -command [list ::TolInspector::ViewFile $objName] + if $InRootFiles { + $data_menu(main) add command -label [mc "Decompile file"] \ + -command [list ::TolInspector::DecompileFile $objName] + } + } else { + $data_menu(main) add cascade -label [mc "View file"] \ + -menu $data_menu(File,View) + foreach objInfo $options_selected(File) { + $data_menu(File,View) add command -label [lindex $objInfo 1] \ + -command [list ::TolInspector::ViewFile [lindex $objInfo 1]] + } + if $InRootFiles { + $data_menu(main) add cascade -label [mc "Decompile file"] \ + -menu $data_menu(File,Decompile) + foreach objInfo $options_selected(File) { + $data_menu(File,Decompile) add command -label [lindex $objInfo 1] \ + -command [list ::TolInspector::DecompileFile [lindex $objInfo 1]] + } + } + } + } + } ;# end del switch + # inserto las opciones definidas en MenuManager + if { $grammar ne "Anything" } { + TolGui_InsertEntriesFromMenuManager \ + $data_menu(main) \ + $options_selected($grammar) + } + + $data_menu(main) add separator + $data_menu(main) add cascade -label [mc "Functions"] \ + -menu $data_menu($grammar,Functions) + ShowMenuUserFunc $grammar + if {[llength $options_selected($grammar)] == 1} { + set objName [lindex [lindex $options_selected($grammar) 0] 1] + set path [lindex [lindex $options_selected($grammar) 0] 2] + $data_menu(main) add command -label [mc "View %1\$s's definition" $grammar] \ + -command [list ::TolInspector::ViewDefinition $objName $path $grammar] + } else { + $data_menu(main) add cascade -label [mc "View %1\$s's definition" $grammar] \ + -menu $data_menu($grammar,File) + foreach objInfo $options_selected($grammar) { + $data_menu($grammar,File) add command -label [lindex $objInfo 1] \ + -command [list ::TolInspector::ViewDefinition\ + [lindex $objInfo 1] [lindex $objInfo 2] $grammar] + } + } + $data_menu(main) add separator + } ;#end del foreach + + # Store selection in oza + if { [ llength $all_objects ] > 1 || [ lindex $grammar_selected 0 ] ne "Set" } { + $data_menu(main) add command -label [mc "Store selection in OZA"]... \ + -command [ list TolGui_StoreSelectionInOZA $all_objects ] + } else { + $data_menu(main) add command -label [mc "Store Set in OZA"]... \ + -command [ list TolGui_StoreSelectionInOZA $all_objects ] + $data_menu(main) add command -label [mc "Store elements in OZA"]... \ + -command [ list TolGui_StoreSetElementsInOZA [ lindex $all_objects 0 ] ] + } + $data_menu(main) add separator + # Store selection in oza + + if { $InRootPool } { + $data_menu(main) add command -label [mc "Remove from spool"] \ + -command [list ::TolInspector::RemoveFromSpool $ht_vars] + } else { + $data_menu(main) add command -label [mc "Add to spool"] \ + -command [list ::TolInspector::AddToSpool $ht_vars [lindex [$ht_tree get -full anchor] 1]] + } + $data_menu(main) add command -label [mc "To Eval window"] \ + -command [list ::TolInspector::AddToEvalWindow $ht_vars] + $data_menu(main) add separator + if { $InRootConsole} { + $data_menu(main) add command -label [mc "Decompile"] \ + -command [list ::TolInspector::ClearConsoleObjSel $ht_vars] + $data_menu(main) add separator + } + $data_menu(main) add command -label [mc "Select all"] \ + -command [list ::TolInspector::SelectAll $ht_vars] + $data_menu(main) add command -label [mc "Toggle selection"] \ + -command [list ::TolInspector::ToggleSelection $ht_vars] + tk_popup $data_menu(main) $x $y + } ;#end del if + } + } +} + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::PostFunction { x y } { +# +# PURPOSE: Composes a popup menu for functions and displays it. Its composed +# depending on the node/s clicked by user. +# +# PARAMETERS: +# x -> x-coordinate where popup menu is drawn +# y -> y-coordinate where popup menu is drawn +# +#///////////////////////////////////////////////////////////////////////////// + variable data_menu + variable vars_selected + variable ht_funcs + variable ht_tree + variable item_data + variable data + + variable tolset + variable tolindex + + array unset options_selected + foreach it [array names data_menu] { + $data_menu($it) delete 0 end + } + + set InRootPool [string equal [lindex [$ht_tree get -full anchor] end] "root-pool"] + set node_act [$ht_funcs index current] + if { [string length $node_act] } { + set vars_selected [$ht_funcs curselection] + if { [lsearch $vars_selected $node_act] >= 0 } { + foreach var $vars_selected { + array set aryData [$ht_funcs entry cget $var -data] + set itemid $aryData(Index) + set path $aryData(Path) + set grammar [lindex $item_data($itemid) 2] + set objName [$ht_funcs entry cget $var -label] + + if { $InRootPool } { + set object $data(pool,variables,$itemid) + } else { + if { [string length $tolset] } { + set object [concat [list $tolset] $tolindex $itemid] + } else { + set object $objName + } + } + # La única gramática seleccionable en ht_funcs es Code + lappend code_selected [list $object $objName $path] + } + + if {[llength $code_selected] == 1} { + set objName [lindex [lindex $code_selected 0] 1] + set path [lindex [lindex $code_selected 0] 2] + $data_menu(main) add command -label [mc "View %1\$s's definition" $grammar] \ + -command [list ::TolInspector::ViewDefinition $objName $path $grammar] + } else { + $data_menu(main) add cascade -label [mc "View %1\$s's definition" $grammar] \ + -menu $data_menu($grammar,File) + foreach objInfo $code_selected { + $data_menu($grammar,File) add command -label [lindex $objInfo 1]\ + -command [list ::TolInspector::ViewDefinition\ + [lindex $objInfo 1] [lindex $objInfo 2] $grammar] + } + } + + if { $InRootPool } { + $data_menu(main) add command -label [mc "Remove from spool"] \ + -command [list ::TolInspector::RemoveFromSpool $ht_funcs] + } else { + $data_menu(main) add command -label [mc "Add to spool"] \ + -command [list ::TolInspector::AddToSpool $ht_funcs [lindex [$ht_tree get -full anchor] 1]] + } + $data_menu(main) add command -label [mc "To Eval window"] \ + -command [list ::TolInspector::AddToEvalWindow $ht_funcs] + $data_menu(main) add separator + $data_menu(main) add command -label [mc "Select all"] \ + -command [list ::TolInspector::SelectAll $ht_funcs] + $data_menu(main) add command -label [mc "Toggle selection"] \ + -command [list ::TolInspector::ToggleSelection $ht_funcs] + tk_popup $data_menu(main) $x $y + } + } +} + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::PostTree { x y } { +# +# PURPOSE: Composes a popup menu for left treeview and displays it. Its +# composed depending on the node clicked by user. +# +# PARAMETERS: +# x -> x-coordinate where popup menu is drawn +# y -> y-coordinate where popup menu is drawn +# +#///////////////////////////////////////////////////////////////////////////// + variable data_menu + variable vars_selected + variable ht_tree + variable item_data + variable data + variable tolset + variable tolindex + variable item_id + #puts "ht_tree: $ht_tree" + #No terminado todavía + #return + array unset options_selected + + #puts "::TolInspector::PostTree $x $y" + foreach it [array names data_menu] { + $data_menu($it) delete 0 end + } + set InRootPool [string equal [lindex [$ht_tree get -full anchor] end-1] "root-pool"] + #puts "InRootPool: $InRootPool" + # InRootFiles has a value 1 if node is a File + set InRootFiles [string equal [lindex [$ht_tree get -full anchor] end-1] "root-files"] + #puts "InRootFiles: $InRootFiles" + # index of the selected node + set node_act [$ht_tree index current] + #puts "node_act: $node_act" + if { [string length $node_act] } { + set vars_selected [$ht_tree curselection] + #puts "vars_selected: $vars_selected" + if { [lsearch $vars_selected $node_act] >= 0 } { ;# Not root node + set index [$ht_tree index anchor] + #puts "index: $index" + if { $index } { + set info_node [split [lindex [$ht_tree get -full $index] end] "-"] + #puts "info_node: $info_node" + set node_type [lindex $info_node 0] + #puts "node_type: $node_type" + set node_name [lindex $info_node 1] + #puts "node_name: $node_name" + } else { ;# root node + set node_type root + set node_name root + } + # if user selects a root or a grammar doesn't nothing + switch -regexp $node_type { + root - + grammar { return } + } + # label of object showed in the tree + set objName [$ht_tree entry cget $index -label] + #puts "objName: $objName" + set object $objName + + if {$InRootFiles} { + array set aryData [$ht_tree entry cget $index -data] + if [info exist aryData(FileName)] { + set objName $aryData(FileName) + } + } + #puts "2objName: $objName" + if { $InRootPool } { + #puts "es InRootPool $item_id" + set itemid $item_id + #set object $data(pool,variables,$itemid) + set object $data(pool,reference,$node_type) + } else { + #puts "NO InRootPool" + if { [string length $tolset] } { + set object [concat [list $tolset] $tolindex] + } else { + set object $objName + } + } + #puts "object = $objName '[$ht_tree entry cget $index -data]'" +#Tolcon_Trace "***********************************" {red} +#Tolcon_Trace "index=$index, node_type=$node_type, node_name=$node_name" {red} +#Tolcon_Trace "tolset=$tolset, tolindex=$tolindex, aryData= [$ht_tree entry cget $index -data]" {red} +#Tolcon_Trace "object=$object, label=$objName" {red} +#Tolcon_Trace "***********************************" {red} + + # + # TICKET: #1438 + # Por que se pregunta aqui por los objetos de consola? + # + set stackList [::tol::console stack list] + #puts "stackList: $stackList" + set stackValue {} + foreach stackItem $stackList { + #puts "stackItem: $stackItem" + #puts "lindex $stackValue 1: [lindex $stackValue 1]" + #puts "objName: $objName" + if {[lindex $stackItem 1] eq $objName} { + set stackValue $stackItem + } + break + } + #puts "stackValue: $stackValue" + set grammar [lindex $stackValue 0] + #puts "grammar: $grammar" + #set full_data $item_data($index) ;# {value} {desc} {grammar} + #set grammar [lindex $full_data 2] + + #foreach fun [::tol::info functions $grammar] { + # set finfo [::tol::info functions $grammar $fun] + # InsertChild Code $fun [lindex $finfo 0] [lindex $finfo 1] [list [lindex $finfo 2]] 0 + #} + if {[catch {set info [::tol::info included $objName]}]} { + if { !($grammar eq "")} { + if {[catch {set info [::tol::info var [list $grammar $object]}]} { + #set info [concat [list "$grammar" $objName ] [::tol::info var $grammar $objName]] + set info [::tol::info var [list $grammar $objName]] + #Tolcon_Trace "INFO de ::tol::info var Set objName" + } else { + set info [::tol::info var [list $grammar $object]] + #Tolcon_Trace "INFO de ::tol::info var $grammar object" + } + set isFile [expr [lindex $info 5] == 4] + } else { + set isFile 0 + } + + } else { + set info [::tol::info included $objName] + #Tolcon_Trace "INFO de ::tol::info included objName" + set isFile 1 + } + #puts "paso" + + if $isFile { + #puts "entro como fichero" + $data_menu(main) add command -label [mc "View file"] \ + -command [list ::TolInspector::ViewFile $objName] + if $InRootFiles { + $data_menu(main) add command -label [mc "Decompile file"] \ + -command [list ::TolInspector::DecompileFile $objName] + } + } else { + #puts "no entro como fichero" + if { $grammar eq "Set" } { + $data_menu(main) add command -label [mc "Table set"] \ + -command [list ::TolInspector::TableSet $object] + $data_menu(main) add command -label [mc "Draw set"] \ + -command [list ::TolInspector::DrawSet $object] + } + } + tk_popup $data_menu(main) $x $y + } + } +} + +#///////////////////////////////////////////////////////////////////////////// +# Procedures asociated with tol inspector popup menu +#///////////////////////////////////////////////////////////////////////////// + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::RemoveFromSpool {ht} { +# +# PURPOSE: Removes from spool all selected objects +# +#///////////////////////////////////////////////////////////////////////////// + variable vars_selected + variable item_data + variable tolset + variable tolindex + variable data + + foreach var $vars_selected { + array set aryData [$ht entry cget $var -data] + set itemid $aryData(Index) + set path $aryData(Path) + set reference $aryData(Reference) + set grammar [lindex $item_data($itemid) 2] + + set objName [$ht entry cget $var -label] + + set _objpool [list "grammar" $grammar "objName" $objName "reference" $reference "path" $path] + if {$grammar eq "Code"} { + set graApply [lindex $aryData(Content) 0] + lappend _objpool "graApply" $graApply + } + #Tolcon_Trace "OBJPOOL on REMOVE: $_objpool" + + # Buscamos el objeto (identificador: referencia) + array set objpool $_objpool + foreach _obj $data(pool,objects) { + array set obj $_obj + #Tolcon_Trace "obj(reference)=$obj(reference), objpool(reference)=$objpool(reference)" + if {[string equal $obj(reference) $objpool(reference)]} { + if {$obj(grammar) eq "Code"} { + if {[string equal $obj(graApply) $objpool(graApply)]} { + set idx [lsearch $data(pool,objects) $_obj] + #Tolcon_Trace "El obj a quitar tiene idx=$idx" + set data(pool,objects) [lreplace $data(pool,objects) $idx $idx] + } + } else { + set idx [lsearch $data(pool,objects) $_obj] + #Tolcon_Trace "El obj a quitar tiene idx=$idx" + set data(pool,objects) [lreplace $data(pool,objects) $idx $idx] + } + } + } + } + #Tolcon_Trace "P.O. after REMOVE: $data(pool,objects)" + UpdatePoolObj +} + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::AddToSpool {ht origin} { +#///////////////////////////////////////////////////////////////////////////// + variable vars_selected + variable item_data + variable tolset + variable tolindex + variable data + + foreach var $vars_selected { + array set aryData [$ht entry cget $var -data] + set itemid $aryData(Index) + set path $aryData(Path) + set grammar [lindex $item_data($itemid) 2] + set objName [$ht entry cget $var -label] + #puts "AddToSpool: Reference=$aryData(Reference) tolset=$tolset grammar=$grammar" + if {[llength $aryData(Reference)]} { + set reference $aryData(Reference) + } else { + if { [string length $tolset] } { + #set object [concat [list $tolset] $tolindex $itemid] + #set object [concat [list File $tolset] $tolindex $itemid] + set object [concat $tolset $tolindex $itemid] + #puts "AddToSpool: object=$object" + set reference [::tol::info reference $object] + } else { + if {$grammar eq "Set"} { + #puts "AddToSpool: origin=$origin" + set reference [::tol::info reference [list Set $objName]] + #Tolcon_Trace "reference de ::tol::info reference [list $objName]" + } else { + if [catch {set reference [::tol::info reference [list $grammar $objName]]}] { + set reference $objName + #Tolcon_Trace "reference NO SE QUE PONER" + } + #Tolcon_Trace "reference de ::tol::info reference $grammar $objName" + } + } + } + set _objpool [list "origin" $origin "grammar" $grammar "objName" $objName "reference" $reference "path" $path] + if {$grammar eq "Code"} { + set graApply [lindex $aryData(Content) 0] + lappend _objpool "graApply" $graApply + } + #Tolcon_Trace "***************" + #Tolcon_Trace "OBJPOOL on ADD:" + #Tolcon_Trace "***************" + #foreach {key value} $_objpool { + # Tolcon_Trace " $key=$value" + #} + set inserted 0 + # Si la referencia es igual, el objeto es el mismo (salvo para obj de tipo Code) + array set objpool $_objpool + foreach _obj $data(pool,objects) { + array set obj $_obj + if {[string equal $obj(reference) $objpool(reference)]} { + #Si es de la gramatica Code miro a ver la gramatica sobre la que se aplica + if {$objpool(grammar) eq "Code"} { + if {[string equal $obj(graApply) $objpool(graApply)]} { + set inserted 1 + } + } else { + set inserted 1 + } + } + } + if {!$inserted} { + lappend data(pool,objects) $_objpool + #puts "AddToSpool: P.O. after ADD: $data(pool,objects)" + } else { + #puts "$_objpool ALREADY IN SPOOL" + } + } + +} + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::AddToEvalWindow {ht} { +# +# PURPOSE: Adds names of selected objects (vars or functions) in treeview ht +# to eval window +# +#///////////////////////////////////////////////////////////////////////////// + variable ht_vars + variable vars_selected + + set names "" + foreach var $vars_selected { + lappend names [$ht entry cget $var -label] + } + ::TolConsole::ToEvalWindow [ListToStr $names] +} + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::SelectAll {ht} { +# +# PURPOSE: Selects all nodes of a given treeview +# +# PARAMETERS: +# ht -> treeview's path +# +#///////////////////////////////////////////////////////////////////////////// + set found [$ht find] + if {[llength $found] > 1} { + $ht selection set [lindex $found 1] [lindex $found end] + } +} + +#///////////////////////////////////////////////////////////////////////////// +proc ::TolInspector::ToggleSelection {ht} { +# +# PURPOSE: Toggles selection of nodes of a given treeview +# +# PARAMETERS: +# ht -> treeview's path +# +#///////////////////////////////////////////////////////////////////////////// + set found [$ht find] + if {[llength $found] > 1} { + $ht selection toggle [lindex $found 1] [lindex $found end] + } +}