Project

General

Profile

Statistics
| Branch: | Revision:

root / src / tkenv / inspector.tcl @ 3e29b8a0

History | View | Annotate | Download (22.9 KB)

1
#=================================================================
2
#  INSPECTOR.TCL - part of
3
#
4
#                     OMNeT++/OMNEST
5
#            Discrete System Simulation in C++
6
#
7
#=================================================================
8

    
9
#----------------------------------------------------------------#
10
#  Copyright (C) 1992-2008 Andras Varga
11
#
12
#  This file is distributed WITHOUT ANY WARRANTY. See the file
13
#  `license' for details on this and other legal matters.
14
#----------------------------------------------------------------#
15

    
16
#
17
# General procs for inspectors
18
#
19

    
20

    
21
#===================================================================
22
#    INSPECTOR TOPLEVEL WINDOWS
23
#===================================================================
24

    
25
#
26
# gets called from concrete inspector subtypes
27
#
28
proc create_inspector_toplevel {w geom} {
29

    
30
    # create toplevel inspector window
31

    
32
    global fonts icons help_tips
33
    global B2 B3
34

    
35
    toplevel $w -class Toplevel
36
    wm focusmodel $w passive
37

    
38
    set state "normal"
39
    regexp {(.*):(.*)} $geom dummy geom state
40
    catch {wm geometry $w $geom}
41
    catch {wm state $w $state}
42

    
43
    #wm maxsize $w 1009 738
44
    wm minsize $w 1 1
45
    wm overrideredirect $w 0
46
    wm resizable $w 1 1
47
    wm protocol $w WM_DELETE_WINDOW "close_inspector_toplevel $w"
48

    
49
    inspectorlist_remove $w
50
    inspectorlist_storename $w
51

    
52
    # add the "Inspect As.." icon at the top
53
    frame $w.toolbar -relief raised -bd 1
54
    pack $w.toolbar -anchor w -side top -fill x -expand 0
55

    
56
    pack_iconbutton $w.toolbar.sep0 -separator
57
    pack_iconbutton $w.toolbar.owner -image $icons(parent) ;#command assigned from C++
58
    pack_iconbutton $w.toolbar.sep01 -separator
59

    
60
    set help_tips($w.toolbar.owner) {Inspect owner object}
61

    
62
    # add object type-and-name bar with color codes
63
    regexp {\.(ptr.*)-[0-9]+} $w match ptr
64
    set colorcode [choosecolorcode $ptr]
65

    
66
    frame $w.infobar -relief raised -bd 1
67
    button $w.infobar.color -anchor w -relief raised -bd 1 -bg $colorcode -activebackground $colorcode -image $icons(1pixtransp) -width 8 -command "inspect_this_as $w"
68
    label $w.infobar.name -anchor w -relief flat -justify left
69
    pack $w.infobar.color -anchor n -side left -expand 0 -fill y -pady 1
70
    pack $w.infobar.name -anchor n -side left -expand 1 -fill both -pady 1
71
    pack $w.infobar -anchor w -side top -fill x -expand 0
72

    
73
    set help_tips($w.infobar.color) {Different inspectors of the same object have the same color}
74
    set help_tips($w.infobar.name)  {Right-click for copying to clipboard}
75

    
76
    # Keyboard bindings
77
    bind $w <Escape>     "catch {.popup unpost}"
78
    bind $w <Button-1>   "catch {.popup unpost}"
79
    bind $w <Key-Return> "opp_writebackinspector $w; opp_updateinspectors"
80

    
81
    bind $w.infobar.name <Button-$B3> [list inspectorNamePopup $ptr %X %Y]
82
    bind $w.infobar.color <Button-$B3> [list inspectorNamePopup $ptr %X %Y]
83

    
84
    bind_runcommands $w
85
    bind_othercommands $w
86
}
87

    
88
proc choosecolorcode {ptr} {
89
    set colors {
90
    gray60 gray70 gray80 gray85 gray90 gray95 \
91
    snow1 snow2 snow3 snow4 seashell1 seashell2 \
92
    seashell3 seashell4 AntiqueWhite1 AntiqueWhite2 AntiqueWhite3 \
93
    AntiqueWhite4 bisque1 bisque2 bisque3 bisque4 PeachPuff1 \
94
    PeachPuff2 PeachPuff3 PeachPuff4 NavajoWhite1 NavajoWhite2 \
95
    NavajoWhite3 NavajoWhite4 LemonChiffon1 LemonChiffon2 \
96
    LemonChiffon3 LemonChiffon4 cornsilk1 cornsilk2 cornsilk3 \
97
    cornsilk4 ivory1 ivory2 ivory3 ivory4 honeydew1 honeydew2 \
98
    honeydew3 honeydew4 LavenderBlush1 LavenderBlush2 \
99
    LavenderBlush3 LavenderBlush4 MistyRose1 MistyRose2 \
100
    MistyRose3 MistyRose4 azure1 azure2 azure3 azure4 \
101
    SlateBlue1 SlateBlue2 SlateBlue3 SlateBlue4 RoyalBlue1 \
102
    RoyalBlue2 RoyalBlue3 RoyalBlue4 blue1 blue2 blue3 blue4 \
103
    DodgerBlue1 DodgerBlue2 DodgerBlue3 DodgerBlue4 SteelBlue1 \
104
    SteelBlue2 SteelBlue3 SteelBlue4 DeepSkyBlue1 DeepSkyBlue2 \
105
    DeepSkyBlue3 DeepSkyBlue4 SkyBlue1 SkyBlue2 SkyBlue3 \
106
    SkyBlue4 LightSkyBlue1 LightSkyBlue2 LightSkyBlue3 \
107
    LightSkyBlue4 SlateGray1 SlateGray2 SlateGray3 SlateGray4 \
108
    LightSteelBlue1 LightSteelBlue2 LightSteelBlue3 \
109
    LightSteelBlue4 LightBlue1 LightBlue2 LightBlue3 \
110
    LightBlue4 LightCyan1 LightCyan2 LightCyan3 LightCyan4 \
111
    PaleTurquoise1 PaleTurquoise2 PaleTurquoise3 PaleTurquoise4 \
112
    CadetBlue1 CadetBlue2 CadetBlue3 CadetBlue4 turquoise1 \
113
    turquoise2 turquoise3 turquoise4 cyan1 cyan2 cyan3 cyan4 \
114
    DarkSlateGray1 DarkSlateGray2 DarkSlateGray3 \
115
    DarkSlateGray4 aquamarine1 aquamarine2 aquamarine3 \
116
    aquamarine4 DarkSeaGreen1 DarkSeaGreen2 DarkSeaGreen3 \
117
    DarkSeaGreen4 SeaGreen1 SeaGreen2 SeaGreen3 SeaGreen4 \
118
    PaleGreen1 PaleGreen2 PaleGreen3 PaleGreen4 SpringGreen1 \
119
    SpringGreen2 SpringGreen3 SpringGreen4 green1 green2 \
120
    green3 green4 chartreuse1 chartreuse2 chartreuse3 \
121
    chartreuse4 OliveDrab1 OliveDrab2 OliveDrab3 OliveDrab4 \
122
    DarkOliveGreen1 DarkOliveGreen2 DarkOliveGreen3 \
123
    DarkOliveGreen4 khaki1 khaki2 khaki3 khaki4 \
124
    LightGoldenrod1 LightGoldenrod2 LightGoldenrod3 \
125
    LightGoldenrod4 LightYellow1 LightYellow2 LightYellow3 \
126
    LightYellow4 yellow1 yellow2 yellow3 yellow4 gold1 gold2 \
127
    gold3 gold4 goldenrod1 goldenrod2 goldenrod3 goldenrod4 \
128
    DarkGoldenrod1 DarkGoldenrod2 DarkGoldenrod3 DarkGoldenrod4 \
129
    RosyBrown1 RosyBrown2 RosyBrown3 RosyBrown4 IndianRed1 \
130
    IndianRed2 IndianRed3 IndianRed4 sienna1 sienna2 sienna3 \
131
    sienna4 burlywood1 burlywood2 burlywood3 burlywood4 wheat1 \
132
    wheat2 wheat3 wheat4 tan1 tan2 tan3 tan4 chocolate1 \
133
    chocolate2 chocolate3 chocolate4 firebrick1 firebrick2 \
134
    firebrick3 firebrick4 brown1 brown2 brown3 brown4 salmon1 \
135
    salmon2 salmon3 salmon4 LightSalmon1 LightSalmon2 \
136
    LightSalmon3 LightSalmon4 orange1 orange2 orange3 orange4 \
137
    DarkOrange1 DarkOrange2 DarkOrange3 DarkOrange4 coral1 \
138
    coral2 coral3 coral4 tomato1 tomato2 tomato3 tomato4 \
139
    OrangeRed1 OrangeRed2 OrangeRed3 OrangeRed4 red1 red2 red3 \
140
    red4 PaleVioletRed1 PaleVioletRed2 PaleVioletRed3 PaleVioletRed4 \
141
    maroon1 maroon2 maroon3 maroon4 VioletRed1 VioletRed2 VioletRed3 \
142
    VioletRed4 magenta1 magenta2 magenta3 magenta4 orchid1 \
143
    orchid2 orchid3 orchid4 plum1 plum2 plum3 plum4 \
144
    MediumOrchid1 MediumOrchid2 MediumOrchid3 MediumOrchid4 \
145
    DarkOrchid1 DarkOrchid2 DarkOrchid3 DarkOrchid4 purple1 \
146
    purple2 purple3 purple4 MediumPurple1 MediumPurple2 \
147
    MediumPurple3 MediumPurple4 thistle1 thistle2 thistle3 \
148
    thistle4
149
    }
150
    set i [opp_getstringhashcode $ptr]
151
    set i [expr $i % [llength $colors]]
152
    return [lindex $colors $i]
153
}
154

    
155
# icons used in the tree view and listboxes
156
set treeicons(cCompoundModule) {compound_vs}
157
set treeicons(cSimpleModule)   {simple_vs}
158
set treeicons(cPlaceholderModule) {placeholder_vs}
159
set treeicons(cGate)           {gate_vs}
160
set treeicons(cPar)            {param_vs}
161
set treeicons(cMessage)        {message_vs}
162
set treeicons(cQueue)          {queue_vs}
163
set treeicons(cLinkedList)     {queue_vs}
164
set treeicons(cArray)          {container_vs}
165
set treeicons(cMessageHeap)    {container_vs}
166
set treeicons(cChannel)        {chan_vs}
167
set treeicons(cStatistic)      {stat_vs}
168
set treeicons(cOutVector)      {outvect_vs}
169

    
170
#
171
# Returns the icon of an object (for tree view / listbox)
172
#
173
proc get_icon_for_object {ptr} {
174
    global icons treeicons
175
    set class [opp_getobjectbaseclass $ptr]
176
    if [info exists treeicons($class)] {
177
       return $icons($treeicons($class))
178
    } else {
179
       return $icons(cogwheel_vs)
180
    }
181
}
182

    
183
#
184
# gets called by the WM (Window Manager)
185
#
186
proc close_inspector_toplevel {w} {
187
    # invokes app->deleteInspector(insp)
188
    opp_deleteinspector $w
189
}
190

    
191

    
192
#
193
# gets called from C++
194
#
195
proc inspector_hostobjectdeleted {w} {
196
    # if the insp window is destroyed because the object no longer exists,
197
    # prepare to reopen it with same geometry if the object reappears
198
    inspectorlist_add $w
199
}
200

    
201
#
202
# gets called from C++
203
#
204
proc destroy_inspector_toplevel {w} {
205
    destroy $w
206
}
207

    
208
#
209
# gets called from C++
210
#
211
proc inspector_show {w} {
212
    show_window $w
213
}
214

    
215
#
216
# Brings the window to front, and gives it focus
217
#
218
proc show_window {w} {
219
    global tcl_platform
220
    if {$tcl_platform(platform) != "windows"} {
221
        # looks like some X servers ignore the "raise" command unless we
222
        # kick them by "wm withdraw" plus "wm deiconify"...
223
        wm withdraw $w
224
        wm deiconify $w
225
    }
226
    raise $w
227
    focus $w
228
}
229

    
230
#
231
# invoked on right-clicking object name inspectors
232
#
233
proc inspectorNamePopup {ptr x y} {
234
    catch {destroy .popup}
235
    menu .popup -tearoff 0
236

    
237
    regsub {^ptr} $ptr {0x} p
238

    
239
    .popup add command -label "Copy pointer with cast (for debugger)" -command [list setClipboard "(([opp_getobjectfield $ptr className] *)$p)"]
240
    .popup add command -label "Copy pointer value (for debugger)" -command [list setClipboard $p]
241
    .popup add separator
242
    .popup add command -label "Copy full path" -command [list setClipboard [opp_getobjectfullpath $ptr]]
243
    .popup add command -label "Copy name" -command [list setClipboard [opp_getobjectfullname $ptr]]
244
    .popup add command -label "Copy class name" -command [list setClipboard [opp_getobjectfield $ptr className]]
245

    
246
    tk_popup .popup $x $y
247
}
248

    
249
proc setClipboard {str} {
250
    clipboard clear
251
    clipboard append -- $str
252
}
253

    
254
#===================================================================
255
#    UTILITY FUNCTIONS FOR INSPECTOR WINDOWS
256
#===================================================================
257

    
258
proc textwindow_add_icons {w {wintype ""}} {
259
    global icons help_tips
260

    
261
    pack_iconbutton $w.toolbar.copy   -image $icons(copy) -command "edit_copy $w.main.text"
262
    pack_iconbutton $w.toolbar.find   -image $icons(find) -command "findDialog $w.main.text"
263
    pack_iconbutton $w.toolbar.save   -image $icons(save) -command "savefile $w"
264
    if {$wintype=="modulewindow"} {
265
        pack_iconbutton $w.toolbar.filter -image $icons(filter) -command "edit_filterwindowcontents $w.main.text"
266
    }
267
    pack_iconbutton $w.toolbar.sep21  -separator
268

    
269
    set help_tips($w.toolbar.copy)   {Copy selected text to clipboard (Ctrl+C)}
270
    set help_tips($w.toolbar.find)   {Find string in window (Ctrl+F)}
271
    set help_tips($w.toolbar.save)   {Save window contents to file}
272
    set help_tips($w.toolbar.filter) {Filter window contents (Ctrl+H)}
273
}
274

    
275
proc create_inspector_listbox {w} {
276
    global B2 B3
277

    
278
    # create a listbox
279

    
280
    label $w.label -text "# objects:"
281
    pack $w.label -side top -anchor w
282

    
283
    frame $w.main
284
    pack $w.main -expand 1 -fill both -side top
285

    
286
    multicolumnlistbox $w.main.list {
287
       {class  Class   80}
288
       {name   Name   120}
289
       {info   Info}
290
       {ptr    Pointer}
291
    } -width 400 -yscrollcommand "$w.main.vsb set" -xscrollcommand "$w.main.hsb set"
292
    scrollbar $w.main.hsb  -command "$w.main.list xview" -orient horiz
293
    scrollbar $w.main.vsb  -command "$w.main.list yview"
294
    grid $w.main.list $w.main.vsb -sticky news
295
    grid $w.main.hsb  x           -sticky news
296
    grid rowconfig    $w.main 0 -weight 1 -minsize 0
297
    grid columnconfig $w.main 0 -weight 1 -minsize 0
298

    
299
    bind $w.main.list <Double-Button-1> {inspect_item_in %W}
300
    bind $w.main.list <Button-$B3> {+inspector_rightclick %W %X %Y}  ;# Note "+"! it appends this code to binding in widgets.tcl
301
    bind $w.main.list <Key-Return> {inspect_item_in %W}
302

    
303
    focus $w.main.list
304
}
305

    
306
proc inspector_rightclick {lb X Y} {
307
    set ptr [lindex [multicolumnlistbox_curselection $lb] 0]
308
    if [opp_isnotnull $ptr] {
309
        set popup [create_inspector_contextmenu $ptr]
310
        tk_popup $popup $X $Y
311
    }
312
}
313

    
314
#
315
# Extends context menu with extra items. Example config for the INET Framework:
316
#
317
# extendContextMenu {
318
#    {"INET: Interfaces"             "**"  "**interfaceTable.interfaces"     "*vector*"}
319
#    {"INET: IP Routing Table"       "**"  "**routingTable.routes"           "*vector*"}
320
#    {"INET: IP Multicast Routes"    "**"  "**routingTable.multicastRoutes"  "*vector*"}
321
#    {"INET: IPv6 Routing Table"     "**"  "**routingTable6.routeList"       "*vector*"}
322
#    {"INET: IPv6 Destination Cache" "**"  "**routingTable6.destCache"       "*map*"   }
323
#    {"INET: ARP cache"              "**"  "**arp.arpCache"                  "*map*"   }
324
#    {"INET: TCP connections"        "**"  "**tcp.tcpAppConnMap"             "*map*"   }
325
#
326
#    {"INET: Interfaces"             "**.interfaceTable"  "interfaces"      "*vector*"}
327
#    {"INET: IP Routing Table"       "**.routingTable"    "routes"          "*vector*"}
328
#    {"INET: IP Multicast Routes"    "**.routingTable"    "multicastRoutes" "*vector*"}
329
#    {"INET: IPv6 Routing Table"     "**.routingTable6"   "routeList"       "*vector*"}
330
#    {"INET: IPv6 Destination Cache" "**.routingTable6"   "destCache"       "*map*"   }
331
#    {"INET: ARP cache"              "**.arp"             "arpCache"        "*map*"   }
332
#    {"INET: TCP connections"        "**.tcp"             "tcpAppConnMap"   "*map*"   }
333
# }
334
#
335
proc extendContextMenu {rules} {
336
    global contextmenurules
337

    
338
    set i [llength $contextmenurules(keys)]
339
    foreach line $rules {
340
       lappend contextmenurules(keys) $i
341
       if {[llength $line]!=4} {
342
           set rulename "\"[lindex $line 0]\""
343
           tk_messageBox -type ok -icon info -title Info -message "Context menu inspector rule $rulename should contain 4 items, ignoring."
344
       } else {
345
           set contextmenurules($i,label)   [lindex $line 0]
346
           set contextmenurules($i,context) [lindex $line 1]
347
           set contextmenurules($i,name)    [lindex $line 2]
348
           set contextmenurules($i,class)   [lindex $line 3]
349
       }
350
       incr i
351
    }
352
}
353

    
354
proc fill_inspector_contextmenu {menu ptr} {
355
    global contextmenurules
356

    
357
    # ptr should never be null, but check it anyway
358
    if [opp_isnull $ptr] {return $menu}
359

    
360
    # add inspector types supported by the object
361
    set insptypes [opp_supported_insp_types $ptr]
362
    foreach type $insptypes {
363
       $menu add command -label "Inspect $type..." -command "opp_inspect $ptr \{$type\}"
364
    }
365

    
366
    # add "run until" menu items
367
    set baseclass [opp_getobjectbaseclass $ptr]
368
    set name [opp_getobjectfullname $ptr]
369
    if {$baseclass=="cSimpleModule" || $baseclass=="cCompoundModule"} {
370
        set w ".$ptr-0"  ;#hack
371
        $menu add separator
372
        $menu add command -label "Run until next event in module '$name'" -command "runsimulation_local $w normal"
373
        $menu add command -label "Fast run until next event in module '$name'" -command "runsimulation_local $w fast"
374
    }
375

    
376
    if {$baseclass=="cMessage"} {
377
        $menu add separator
378
        $menu add command -label "Run until message '$name'" -command "run_until_msg $ptr normal"
379
        $menu add command -label "Fast run until message '$name'" -command "run_until_msg $ptr fast"
380
        $menu add command -label "Express run until message '$name'" -command "run_until_msg $ptr express"
381
    }
382

    
383
    # add further menu items
384
    set name [opp_getobjectfullpath $ptr]
385
    set allcategories "mqsgvo"
386
    set first 1
387
    foreach key $contextmenurules(keys) {
388
       #debug "trying $contextmenurules($key,label): opp_getsubobjectsfilt $ptr $allcategories $contextmenurules($key,class) $name.$contextmenurules($key,name) 1"
389
       # check context matches
390
       if ![opp_patmatch $name $contextmenurules($key,context)] {
391
           continue
392
       }
393
       # check we have such object
394
       # Note: we have to quote the pattern for the object matcher, because $name might contain spaces
395
       set objlist [opp_getsubobjectsfilt $ptr $allcategories $contextmenurules($key,class) "\"$name.$contextmenurules($key,name)\"" 1 ""]
396
       if {$objlist!={}} {
397
           if {$first} {
398
               set first 0
399
               $menu add separator
400
           }
401
           $menu add command -label "$contextmenurules($key,label)..." -command "inspect_contextmenurules $ptr $key"
402
       }
403
    }
404
}
405

    
406
proc create_inspector_contextmenu {ptrs} {
407

    
408
    # create popup menu
409
    catch {destroy .popup}
410
    menu .popup -tearoff 0
411

    
412
    if {[llength $ptrs] == 1} {
413
        fill_inspector_contextmenu .popup $ptrs
414
    } else {
415
        foreach ptr $ptrs {
416
            set submenu .popup.$ptr
417
            catch {destroy $submenu}
418
            menu $submenu -tearoff 0
419
            set name [opp_getobjectfullname $ptr]
420
            set shorttypename [opp_getobjectshorttypename $ptr]
421
            set infostr "$shorttypename, [opp_getobjectinfostring $ptr]"
422
            if {[string length $infostr] > 30} {
423
                set infostr [string range $infostr 0 29]...
424
            }
425
            set baseclass [opp_getobjectbaseclass $ptr]
426
            if {$baseclass == "cGate" } {
427
                set nextgateptr [opp_getobjectfield $ptr "nextGate"]
428
                set nextgatename [opp_getobjectfullname $nextgateptr]
429
                set ownerptr [opp_getobjectowner $ptr]
430
                set ownername [opp_getobjectfullname $ownerptr]
431
                set nextgateownerptr [opp_getobjectowner $nextgateptr]
432
                set nextgateownername [opp_getobjectfullname $nextgateownerptr]
433

    
434
                set label "$ownername.$name --> $nextgateownername.$nextgatename"
435
            } elseif {$baseclass == "cMessage" } {
436
                set shortinfo [opp_getmessageshortinfostring $ptr]
437
                set label "$name ($shorttypename, $shortinfo)"
438
            } else {
439
                set label "$name ($infostr)"
440
            }
441
            fill_inspector_contextmenu $submenu $ptr
442
            .popup add cascade -label $label -menu $submenu
443
        }
444
    }
445

    
446
    return .popup
447
}
448

    
449
proc inspect_contextmenurules {ptr key} {
450
    global contextmenurules
451
    set allcategories "mqsgvo"
452
    set name [opp_getobjectfullpath $ptr]
453
    set objlist [opp_getsubobjectsfilt $ptr $allcategories $contextmenurules($key,class) "$name.$contextmenurules($key,name)" 100 ""]
454
    if {[llength $objlist] > 5} {
455
        tk_messageBox -type ok -icon info -title Info -message "This matches [llength $objlist]+ objects, opening inspectors only for the first five."
456
        set objlist [lrange $objlist 0 4]
457
    }
458
    foreach objptr $objlist {
459
        opp_inspect $objptr "(default)"
460
    }
461
}
462

    
463
proc ask_inspectortype {ptr parentwin {typelist {}}} {
464
    set w .asktype
465

    
466
    if {$typelist=={}} {
467
        set typelist [opp_supported_insp_types $ptr]
468
    }
469

    
470
    # if there's only one, use yes/no dialog instead
471
    if {[llength $typelist]==1} {
472
        set type [lindex $typelist 0]
473
        set ans [tk_messageBox -message "Open inspector of type '$type'?" \
474
                  -title "Open inspector" -icon question -type yesno -parent $parentwin]
475
        if {$ans == "yes"} {
476
            return [lindex $typelist 0]
477
        } else {
478
            return ""
479
        }
480
    }
481

    
482
    # chooser dialog
483
    createOkCancelDialog $w {Open Inspector}
484
    label-combo $w.f.type {Choose type:} $typelist
485
    pack $w.f.type -expand 0 -fill x -side top
486

    
487
    set type ""
488
    if [execOkCancelDialog $w] {
489
        set type [$w.f.type.e cget -value]
490

    
491
        if {[lsearch $typelist $type] == -1} {
492
            messagebox {Error} "Invalid inspector type. Please choose from the list." error ok
493
            set type ""
494
        }
495
    }
496
    destroy $w
497

    
498
    return $type
499
}
500

    
501
proc inspect_item_in {lb} {
502
    # called on double-clicking in a container inspector;
503
    # inspect the current item in the listbox of an inspector listwindow
504

    
505
    set ptr [lindex [multicolumnlistbox_curselection $lb] 0]
506
    if [opp_isnotnull $ptr] {
507
        opp_inspect $ptr {(default)}
508
    }
509
}
510

    
511
proc inspectas_item_in {lb} {
512
    # called on double-clicking in a container inspector;
513
    # inspect the current item in the listbox of an inspector listwindow
514

    
515
    set ptr [lindex [multicolumnlistbox_curselection $lb] 0]
516
    if {$sel != ""} {
517
        set type [ask_inspectortype $ptr [winfo toplevel $lb]]
518
        if {$type != ""} {
519
            opp_inspect $ptr $type
520
        }
521
    }
522
}
523

    
524
proc inspect_this_as {win} {
525
    # called by the "Inspect As.." button at the TOP of an inspector
526
    # extract object pointer from window path name and create inpector
527
    regexp {\.(ptr.*)-([0-9]+)} $win match ptr curtype
528

    
529
    # do not offer the type of the inspector from which we're invoked
530
    set typelist [opp_supported_insp_types $ptr]
531
    set pos [lsearch $typelist [opp_inspectortype $curtype]]
532
    set typelist [lreplace $typelist $pos $pos]
533

    
534
    # if no choice, don't do anything
535
    if {[llength $typelist]==0} {return}
536

    
537
    # type selection dialog
538
    set type [ask_inspectortype $ptr $win $typelist]
539
    if {$type != ""} {
540
        opp_inspect $ptr $type
541
    }
542
}
543

    
544
proc inspect_this {win type} {
545
    # extract object pointer from window path name and create inspector
546
    regexp {\.(ptr.*)-[0-9]+} $win match object
547
    opp_inspect $object $type
548
}
549

    
550
proc inspect_componenttype {win {type "(default)"}} {
551
    # extract object pointer from window path name and create inspector
552
    regexp {\.(ptr.*)-[0-9]+} $win match ptr
553

    
554
    set typeptr [opp_getcomponenttypeobject $ptr]
555
    opp_inspect $typeptr $type
556
}
557

    
558
#
559
# Called from balloon.tcl, supposed to return tooltip for a widget (or items
560
# in a widget). Installed via: set help_tips(helptip_proc) get_help_tip
561
#
562
# Here we produce help text for canvas items that represent simulation
563
# objects.
564
#
565
proc get_help_tip {w x y} {
566
   if {![winfo exists $w]} {
567
       return ""
568
   }
569
   set tip ""
570

    
571
   if {[winfo class $w]=="Canvas"} {
572
     set canvasx [$w canvasx $x]
573
     set canvasy [$w canvasy $y]
574
     set items [$w find overlapping [expr $canvasx-2] [expr $canvasy-2] [expr $canvasx+2] [expr $canvasy+2]]
575

    
576
     set tip ""
577
     foreach item $items {
578
       # if this is a simulation object, get its pointer
579
       set ptr ""
580
       set tags [$w gettags $item]
581
       if {[lsearch $tags "tooltip"] == -1} {
582
          continue
583
       }
584

    
585
       if {[lsearch $tags "ptr*"] != -1} {
586
          regexp "ptr.*" $tags ptr
587
       } elseif {[lsearch $tags "qlen-ptr*"] != -1} {
588
          regexp "ptr.*" $tags modptr
589
          set ptr [graphmodwin_qlen_getqptr $w $modptr]
590
       } elseif {[lsearch $tags "node-ptr*"] != -1} {
591
          regexp "ptr.*" $tags ptr
592
       } elseif {[lsearch $tags "node-*"] != -1} {
593
          set i [lsearch $tags "node-*"]
594
          set tag [lindex $tags $i]
595
          regexp "node-(.*)" $tag match node
596
          return [Tree:gettooltip $w $node]
597
       }
598
       set ptr [lindex $ptr 0]
599

    
600
       if [opp_isnotnull $ptr] {
601
          append tip "([opp_getobjectshorttypename $ptr]) [opp_getobjectfullname $ptr]"
602
          set info [opp_getobjectinfostring $ptr]
603
          if {$info!=""} {append tip ", $info"}
604
          regsub {  +} $tip {  } tip
605
          if {[lsearch $tags "modname"] == -1} {
606
             set dispstr ""
607
             catch { set dispstr [opp_getobjectfield $ptr displayString] }
608
             set tt_tag [opp_displaystring $dispstr getTagArg "tt" 0 $ptr 1]
609
          } else {
610
             # if it has tag "modname", it is the enclosing module
611
             set dispstr ""
612
             catch { set dispstr [opp_getobjectfield $ptr displayString] }
613
             set tt_tag [opp_displaystring $dispstr getTagArg "bgtt" 0 $ptr 0]
614
          }
615
          if {$tt_tag!=""} {
616
             append tip "\n  $tt_tag"
617
          }
618
       }
619
       append tip "\n"
620
     }
621
   }
622
   return [string trim $tip \n]
623
}
624

    
625

    
626
proc inspector_createnotebook {w} {
627
    set nb $w.nb
628
    notebook $nb
629
    $nb config -width 460 -height 260
630
    pack $nb -expand 1 -fill both
631
    return $nb
632
}
633