Statistics
| Branch: | Revision:

root / src / tkenv / dialogs.tcl @ fbe00e73

History | View | Annotate | Download (51.7 KB)

1 01873262 Georg Kunz
#=================================================================
2
#  DIALOGS.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
#    HELPER/GUI PROCEDURES
18
#===================================================================
19
20
proc inputbox {title prompt variable {checkboxlabel {}} {checkboxvar {}}} {
21
    # This procedure displays a dialog box, waits for a button in the dialog
22
    # to be invoked, then returns the index of the selected button.
23
24
    upvar $variable var
25
26
    set w .inputbox
27
    createOkCancelDialog $w $title
28
29
    label $w.f.l -text $prompt
30
    entry $w.f.e -highlightthickness 0
31
    pack $w.f.l -anchor w -expand 0 -fill none -padx 2 -pady 2 -side top
32
    pack $w.f.e -anchor w -expand 1 -fill x -padx 2 -pady 2 -side top
33
    $w.f.e insert 0 $var
34
    $w.f.e selection range 0 end
35
36
    if {$checkboxlabel != ""} {
37
        global tmp
38
        upvar $checkboxvar cbvar
39
        set tmp(check) $cbvar
40
        checkbutton $w.f.c -text $checkboxlabel -variable tmp(check)
41
        pack $w.f.c -anchor w -expand 0 -fill x -padx 4 -pady 2 -side top
42
    }
43
44
    setinitialdialogfocus $w.f.e
45
46
    if [execOkCancelDialog $w] {
47
        set var [$w.f.e get]
48
        if {$checkboxlabel != ""} {
49
            set cbvar $tmp(check)
50
        }
51
        destroy $w
52
        return 1
53
    }
54
    destroy $w
55
    return 0
56
}
57
58
proc messagebox {title msg icon type} {
59
    return [tk_messageBox -title $title -message $msg -icon $icon -type $type]
60
}
61
62
proc comboSelectionDialog {title text label variable list} {
63
    set w .combodialog
64
    createOkCancelDialog $w $title
65
66
    upvar $variable var
67
68
    label $w.f.m -text $text -anchor w -justify left
69
    label-combo $w.f.c $label $list $var
70
    pack $w.f.m -fill x -padx 2 -pady 2 -side top
71
    pack $w.f.c -fill x -padx 2 -pady 2 -side top
72
    setinitialdialogfocus $w.f.c.e
73
74
    $w.f.c.e config -width 30
75
76
    if [execOkCancelDialog $w] {
77
        set var [$w.f.c.e cget -value]
78
        destroy $w
79
        return 1
80
    }
81
    destroy $w
82
    return 0
83
}
84
85
#
86
# For selecting config and run number.
87
#
88
proc runSelectionDialog {configname_var runnumber_var} {
89
    set w .runseldialog
90
    createOkCancelDialog $w "Set up an Inifile Configuration"
91
92
    upvar $configname_var configname
93
    upvar $runnumber_var  runnumber
94
95
    set ok 0
96
97
    if {[catch {
98
        set sortedconfignames [runSelectionDialog:groupAndSortConfigNames]
99
100
        set configlist {}
101
        set isbase 0
102
        foreach name $sortedconfignames {
103
            if {$name == ""} {set isbase 1; continue}
104
105
            set desc [opp_getconfigdescription $name]
106
            set runs [opp_getnumrunsinconfig $name]
107
            # NOTE: if you change this, change proc runSelectionDialog:extractConfigName too
108
            #if {$isbase} {append name " -- base config"}
109
            if {$isbase} {set name "($name)"}
110
            if {$desc != ""} {append name " -- $desc"}
111
            if {$runs == 0}   {append name " (invalid config, generates 0 runs)"}
112
            if {$runs > 1}   {append name " (config with $runs runs)"}
113
            lappend configlist $name
114
        }
115
116
        if {($configname=="" || $configname=="General") && $configlist!={}} {
117
            set configname [lindex $configlist 0]
118
        }
119
120
        label $w.f.m -anchor w -justify left -text "Set up one of the configurations defined in omnetpp.ini."
121
        label-combo $w.f.c "Config name:" $configlist $configname
122
        label-combo $w.f.c2 "Run number:" {} $runnumber
123
        pack $w.f.m -fill x -padx 2 -pady 2 -side top
124
        pack $w.f.c -fill x -padx 2 -pady 2 -side top
125
        pack $w.f.c2 -fill x -padx 2 -pady 2 -side top
126
        setinitialdialogfocus $w.f.c.e
127
128
        $w.f.c.e config -width 30
129
        $w.f.c2.e config -width 10
130
131
        combo-onchange $w.f.c.e [list runSelectionDialog:update $w]
132
133
        runSelectionDialog:update $w
134
135
        if [execOkCancelDialog $w] {
136
            set configname [runSelectionDialog:extractConfigName [$w.f.c.e cget -value]]
137
            set runnumber  [$w.f.c2.e cget -value]
138
            if ![string is integer $runnumber] {
139
                messagebox "Error" "Run number must be numeric." info ok
140
                set runnumber 0
141
            } else {
142
                set ok 1
143
            }
144
        }
145
146
    } err]} {
147
        messagebox "Error" $err error ok
148
    }
149
    destroy $w
150
    return $ok
151
}
152
153
proc runSelectionDialog:groupAndSortConfigNames {} {
154
    foreach c [opp_getconfignames] {
155
        set base [opp_getbaseconfig $c]
156
        if {$base != ""} {
157
            set hasderivedconfig($base) 1
158
        }
159
    }
160
161
    set leaf {}
162
    set nonleaf {}
163
    foreach c [opp_getconfignames] {
164
        if [info exist hasderivedconfig($c)] {
165
            lappend nonleaf $c
166
        } else {
167
            lappend leaf $c
168
        }
169
    }
170
171
    return [concat $leaf {{}} $nonleaf]
172
}
173
174
proc runSelectionDialog:extractConfigName {s} {
175
    set s [regsub " -- .*\$" $s ""]
176
    set s [regsub " \\(.*\\)\$" $s ""]
177
    set s [regsub "^\\((.*)\\)\$" $s "\\1"]
178
    return $s
179
}
180
181
proc runSelectionDialog:update {w} {
182
    # fill run number combo with runs of the selected config
183
    set configname [runSelectionDialog:extractConfigName [$w.f.c.e cget -value]]
184
    set n 0
185
    catch {set n [opp_getnumrunsinconfig $configname]}
186
187
    if {$n>1} {
188
        $w.f.c2.e config -state normal
189
    }
190
191
    $w.f.c2.e list delete 0 end
192
    for {set i 0} {$i<$n} {incr i} {
193
        $w.f.c2.e list insert end $i
194
    }
195
196
    # ensure run number is in the valid range
197
    set runnumber  [$w.f.c2.e cget -value]
198
    if {$n<=1} {
199
        $w.f.c2.e config -value ""
200
    }
201
    if {![string is integer $runnumber] || $runnumber<0 || $runnumber>=$n} {
202
        $w.f.c2.e config -value "0"
203
    }
204
205
    if {$n<=1} {
206
        $w.f.c2.e config -state disabled
207
    }
208
}
209
210
proc display_stopdialog {} {
211
    # Create a dialog that can be used to stop a running simulation
212
    global opp fonts tmp
213
214
    # 1. Create and configure dialog
215
    set topwindow "."
216
    catch {set topwindow [winfo toplevel [focus]]}
217
    if {$topwindow=="" || $topwindow=="."} {
218
        set w .stopdialog
219
    } else {
220
        set w $topwindow.stopdialog
221
    }
222
    set tmp(stopdialog) $w
223
224
    if {[winfo exists $w]} return
225
226
    toplevel $w
227
    wm title $w {Running...}
228
    wm transient $w [winfo toplevel [winfo parent $w]]
229
    wm protocol $w WM_DELETE_WINDOW {opp_stopsimulation}
230
    # bind $w <Visibility> "raise $w"  ;# Keep modal window on top -- not good! (obscures error dialogs)
231
232
    set red #f83030
233
    button $w.stopbutton  -text "STOP!" -background $red -activebackground $red \
234
          -borderwidth 6 -font $fonts(big) -command {opp_stopsimulation}
235
    checkbutton $w.autoupdate -text "auto-update inspectors" -variable opp(autoupdate) -command "stopdialog_autoupdate $w"
236
    button $w.updatebutton  -text "  Update now  " -borderwidth 1 -command {opp_updateinspectors}
237
238
    grid $w.stopbutton   -sticky news -padx 4 -pady 3
239
    grid $w.autoupdate   -sticky nes -padx 4 -pady 0
240
    grid $w.updatebutton -sticky nes -padx 4 -pady 3
241
242
    bind $w <Return> "opp_stopsimulation"
243
    bind $w <Escape> "opp_stopsimulation"
244
    bind $w <F8>     "opp_stopsimulation"
245
246
    set opp(autoupdate) [opp_getsimoption expressmode_autoupdate]
247
    stopdialog_autoupdate $w
248
249
    # 2. Center window
250
    center $w
251
252
    # 3. Set a grab and claim the focus too.
253
254
    set opp(oldFocus) [focus]
255
    set opp(oldGrab) [grab current $w]
256
    grab $w
257
    focus $w.stopbutton
258
}
259
260
proc stopdialog_autoupdate {w} {
261
    global opp
262
    if {$opp(autoupdate)} {
263
        opp_setsimoption expressmode_autoupdate 1
264
        $w.updatebutton config -state disabled
265
    } else {
266
        opp_setsimoption expressmode_autoupdate 0
267
        $w.updatebutton config -state normal
268
    }
269
}
270
271
proc remove_stopdialog {} {
272
    # Remove the dialog created by display_stopdialog
273
274
    global opp tmp
275
    if ![info exist tmp(stopdialog)] {
276
        return
277
    }
278
279
    set w $tmp(stopdialog)
280
    if {![winfo exists $w]} return
281
282
    # Restore the focus before deleting the window, since otherwise the
283
    # window manager may take the focus away so we can't redirect it.
284
    # Finally, restore any grab that was in effect.
285
286
    catch {focus $opp(oldFocus)}
287
    destroy $w
288
    if {$opp(oldGrab) != ""} {
289
        grab $opp(oldGrab)
290
    }
291
}
292
293
proc options_dialog {parent {defaultpage "g"}} {
294
    global opp config fonts help_tips helptexts
295
296
    set parent [winfo toplevel $parent]
297
298
    if {$parent == "."} {
299
        set w .optionsdialog
300
    } else {
301
        set w $parent.optionsdialog
302
    }
303
304
    createOkCancelDialog $w {Simulation Options}
305
306
    notebook $w.f.nb
307
    set nb $w.f.nb
308
309
    notebook_addpage $nb g General
310
    notebook_addpage $nb l Layouting
311
    notebook_addpage $nb a Animation
312
    notebook_addpage $nb t Timeline
313
    pack $nb -expand 1 -fill both
314
315
    notebook_showpage $nb $defaultpage
316
317
    # "General" page
318
    labelframe $nb.g.f1 -text "Simulation Execution" -relief groove -borderwidth 2
319
    label-entry $nb.g.f1.updfreq_fast    {Display update frequency for Fast Run (ms):}
320
    label-entry $nb.g.f1.updfreq_express {Display update frequency for Express Run (ms):}
321
    label-entry $nb.g.f1.stepdelay       {Per-event delay for slow execution (ms):}
322
    checkbutton $nb.g.f1.confirmexit -text {Confirm exit when simulation is in progress} -variable opp(confirmexit)
323
    $nb.g.f1.updfreq_fast.l config -width 0
324
    $nb.g.f1.updfreq_express.l config -width 0
325
    $nb.g.f1.stepdelay.l config -width 0
326
    pack $nb.g.f1.updfreq_fast -anchor w -fill x
327
    pack $nb.g.f1.updfreq_express -anchor w -fill x
328
    pack $nb.g.f1.stepdelay -anchor w -fill x
329
    pack $nb.g.f1.confirmexit -anchor w
330
331
    labelframe $nb.g.f2 -text "Logs" -relief groove -borderwidth 2
332
    checkbutton $nb.g.f2.usemainwin -text {Use main window for module output} -variable opp(usemainwin)
333
    checkbutton $nb.g.f2.initbanners -text {Print initialization banners} -variable opp(initbanners)
334
    checkbutton $nb.g.f2.eventbanners -text {Print event banners} -variable opp(eventbanners)
335
    checkbutton $nb.g.f2.shortbanners -text {Short event banners} -variable opp(shortbanners)
336
    label-entry $nb.g.f2.numlines {Scrollback buffer (lines):}
337
    commentlabel $nb.g.f2.c1 {Applies to main window and module log windows. Leave blank for unlimited. Minimum value is 500 lines.}
338
339
    $nb.g.f2.numlines.l config -width 0
340
    pack $nb.g.f2.usemainwin -anchor w
341
    pack $nb.g.f2.initbanners -anchor w
342
    pack $nb.g.f2.eventbanners -anchor w
343
    pack $nb.g.f2.shortbanners -anchor w -padx 10
344
    pack $nb.g.f2.numlines -anchor w -fill x
345
    pack $nb.g.f2.c1 -anchor w
346
347
    labelframe $nb.g.f3 -text "Fonts" -relief groove -borderwidth 2
348
    label-fontcombo $nb.g.f3.fixedfont  {Text window font:} {}
349
    label-fontcombo $nb.g.f3.listboxfont  {Listbox font:} {}
350
    commentlabel $nb.g.f3.note {Examples: fixed, fixed 12, Courier 8, Helvetica 12 bold. NOTE: The font system may substitute another font if the given font is not available.}
351
    pack $nb.g.f3.fixedfont -anchor w -fill x
352
    pack $nb.g.f3.listboxfont -anchor w -fill x
353
    pack $nb.g.f3.note -anchor w -fill x
354
355
    pack $nb.g.f2 -anchor center -expand 0 -fill x -ipadx 0 -ipady 0 -padx 10 -pady 5 -side top
356
    pack $nb.g.f1 -anchor center -expand 0 -fill x -ipadx 0 -ipady 0 -padx 10 -pady 5 -side top
357
    pack $nb.g.f3 -anchor center -expand 0 -fill x -ipadx 0 -ipady 0 -padx 10 -pady 5 -side top
358
359
    # "Layouting" page
360
    labelframe $nb.l.f1 -text "Layouting" -relief groove -borderwidth 2
361
    label $nb.l.f1.layouterlabel -text "Layouting algorithm:"
362
    frame $nb.l.f1.layouter
363
    radiobutton  $nb.l.f1.layouter.fast -text "Fast" -variable opp(layouterchoice) -value "fast"
364
    radiobutton  $nb.l.f1.layouter.advanced -text "Advanced" -variable opp(layouterchoice) -value "advanced"
365
    radiobutton  $nb.l.f1.layouter.auto -text "Adaptive (Fast for large networks, Advanced for smaller ones)" -variable opp(layouterchoice) -value "auto"
366
    checkbutton $nb.l.f1.layouting -text {Show layouting process} -variable opp(layouting)
367
    labelframe $nb.l.f2 -text "Display" -relief groove -borderwidth 2
368
    checkbutton $nb.l.f2.arrangevectorconnections -text {Arrange connections on vector gates parallel to each other} -variable opp(arrangevectorconnections)
369
    checkbutton $nb.l.f2.allowresize -text {Resize window to fit network with current zoom level first} -variable opp(allowresize)
370
    checkbutton $nb.l.f2.allowzoom -text {Zoom out if necessary to fit network into window} -variable opp(allowzoom)
371
    label-entry $nb.l.f2.iconminsize  {Minimum icon size when zoomed out (pixels):}
372
    $nb.l.f2.iconminsize.l config -width 0
373
374
    pack $nb.l.f1.layouterlabel -anchor w
375
    pack $nb.l.f1.layouter -anchor w
376
    pack $nb.l.f1.layouter.fast -anchor w -padx 10
377
    pack $nb.l.f1.layouter.advanced -anchor w -padx 10
378
    pack $nb.l.f1.layouter.auto -anchor w -padx 10
379
    pack $nb.l.f1.layouting -anchor w
380
    pack $nb.l.f2.arrangevectorconnections -anchor w
381
    pack $nb.l.f2.iconminsize -anchor w -fill x
382
    pack $nb.l.f2.allowresize -anchor w
383
    pack $nb.l.f2.allowzoom -anchor w
384
    pack $nb.l.f1 -anchor center -expand 0 -fill x -ipadx 0 -ipady 0 -padx 10 -pady 5 -side top
385
    pack $nb.l.f2 -anchor center -expand 0 -fill x -ipadx 0 -ipady 0 -padx 10 -pady 5 -side top
386
387
    # "Timeline" page
388
    checkbutton $nb.t.tlwantself -text {Display self-messages in the timeline} -variable opp(timeline-wantselfmsgs)
389
    checkbutton $nb.t.tlwantnonself -text {Display non-self messages in the timeline} -variable opp(timeline-wantnonselfmsgs)
390
    label-entry-help $nb.t.tlnamepattern {Message name filter:} $helptexts(timeline-namepattern)
391
    label-entry-help $nb.t.tlclassnamepattern {Class name filter:} $helptexts(timeline-classnamepattern)
392
    commentlabel $nb.t.c1 {Wildcards, AND, OR, NOT, numeric ranges, field matchers like kind, length, etc. accepted. Hover with the mouse over the controls for more info.}
393
    $nb.t.tlnamepattern.l config -width 20
394
    $nb.t.tlclassnamepattern.l config -width 20
395
    $nb.t.tlnamepattern.e config -width 40
396
    $nb.t.tlclassnamepattern.e config -width 40
397
    pack $nb.t.tlwantself -anchor w
398
    pack $nb.t.tlwantnonself -anchor w
399
    pack $nb.t.tlnamepattern -anchor w -fill x
400
    pack $nb.t.tlclassnamepattern -anchor w -fill x
401
    pack $nb.t.c1 -anchor w
402
403
    # "Animation" page
404
    labelframe $nb.a.f1 -text "General" -relief groove -borderwidth 2
405
    checkbutton $nb.a.f1.anim -text {Animate messages} -variable opp(anim)
406
    label-scale $nb.a.f1.speed {Animation speed:}
407
    $nb.a.f1.speed.e config -length 200 -from 0 -to 3 -resolution 0.01 -variable opp(speed)
408
    checkbutton $nb.a.f1.concanim -text {Broadcast animation} -variable opp(concanim)
409
    commentlabel $nb.a.f1.ca "Animates send/sendDirect calls concurrently, after processing\neach event (i.e. out of sequence)"
410
    checkbutton $nb.a.f1.nextev -text {Show next event markers} -variable opp(nextev)
411
    checkbutton $nb.a.f1.sdarrows -text {Show arrows for sendDirect animation} -variable opp(sdarrows)
412
    checkbutton $nb.a.f1.bubbles -text {Show bubbles (bubble() calls)} -variable opp(bubbles)
413
    checkbutton $nb.a.f1.animmeth -text {Animate method calls} -variable opp(animmeth)
414
    label-scale $nb.a.f1.methdelay {Method call delay (ms):}
415
    $nb.a.f1.methdelay.e config -length 200 -from 0 -to 3000 -resolution 1 -variable opp(methdelay)
416
    labelframe $nb.a.f2 -text "Messages" -relief groove -borderwidth 2
417
    checkbutton $nb.a.f2.msgnam -text {Display message names during animation} -variable opp(msgnam)
418
    checkbutton $nb.a.f2.msgclass -text {Display message class during animation} -variable opp(msgclass)
419
    checkbutton $nb.a.f2.msgcol -text {Color messages by message kind} -variable opp(msgcol)
420
    commentlabel $nb.a.f2.c {Color code (message kind modulo 8): 0=red 1=green 2=blue 3=white 4=yellow 5=cyan 6=magenta 7=black}
421
    checkbutton $nb.a.f2.penguin -text {Penguin mode} -variable opp(penguin)
422
423
    pack $nb.a.f1.anim -anchor w
424
    pack $nb.a.f1.speed -anchor w -expand 0 -fill x
425
    pack $nb.a.f1.concanim -anchor w
426
    pack $nb.a.f1.ca -anchor w
427
    pack $nb.a.f1.nextev -anchor w
428
    pack $nb.a.f1.sdarrows -anchor w
429
    pack $nb.a.f1.bubbles -anchor w
430
    pack $nb.a.f1.animmeth -anchor w
431
    pack $nb.a.f1.methdelay -anchor w -expand 0 -fill x
432
    pack $nb.a.f2.msgnam -anchor w
433
    pack $nb.a.f2.msgclass -anchor w
434
    pack $nb.a.f2.msgcol -anchor w
435
    pack $nb.a.f2.c -anchor w
436
    pack $nb.a.f2.penguin -anchor w
437
438
    pack $nb.a.f1 -anchor center -expand 0 -fill x -ipadx 0 -ipady 0 -padx 10 -pady 5 -side top
439
    pack $nb.a.f2 -anchor center -expand 0 -fill x -ipadx 0 -ipady 0 -padx 10 -pady 5 -side top
440
441
    # Configure dialog
442
    $nb.g.f1.updfreq_fast.e insert 0 [opp_getsimoption updatefreq_fast_ms]
443
    $nb.g.f1.updfreq_express.e insert 0 [opp_getsimoption updatefreq_express_ms]
444
    $nb.g.f1.stepdelay.e insert 0 [opp_getsimoption stepdelay]
445
    $nb.g.f2.numlines.e insert 0 $config(logwindow-scrollbacklines)
446
    $nb.l.f2.iconminsize.e insert 0 [opp_getsimoption iconminsize]
447
    set opp(usemainwin) [opp_getsimoption use_mainwindow]
448
    set opp(eventbanners) [opp_getsimoption event_banners]
449
    set opp(initbanners) [opp_getsimoption init_banners]
450
    set opp(shortbanners) [opp_getsimoption short_banners]
451
    set opp(anim)       [opp_getsimoption animation_enabled]
452
    set opp(concanim)   $config(concurrent-anim)
453
    set opp(nextev)     [opp_getsimoption nexteventmarkers]
454
    set opp(sdarrows)   [opp_getsimoption senddirect_arrows]
455
    set opp(animmeth)   [opp_getsimoption anim_methodcalls]
456
    set opp(methdelay)  [opp_getsimoption methodcalls_delay]
457
    set opp(msgnam)     [opp_getsimoption animation_msgnames]
458
    set opp(msgclass)   [opp_getsimoption animation_msgclassnames]
459
    set opp(msgcol)     [opp_getsimoption animation_msgcolors]
460
    set opp(penguin)    [opp_getsimoption penguin_mode]
461
    set opp(layouting)  [opp_getsimoption showlayouting]
462
    set opp(layouterchoice) [opp_getsimoption layouterchoice]
463
    set opp(arrangevectorconnections) [opp_getsimoption arrangevectorconnections]
464
    set opp(bubbles)    [opp_getsimoption bubbles]
465
    set opp(speed)      [opp_getsimoption animation_speed]
466
    set opp(confirmexit) $config(confirm-exit)
467
    set opp(allowresize) $config(layout-may-resize-window)
468
    set opp(allowzoom)   $config(layout-may-change-zoom)
469
470
    $nb.t.tlnamepattern.e insert 0      $config(timeline-msgnamepattern)
471
    $nb.t.tlclassnamepattern.e insert 0 $config(timeline-msgclassnamepattern)
472
    set opp(timeline-wantselfmsgs)      $config(timeline-wantselfmsgs)
473
    set opp(timeline-wantnonselfmsgs)   $config(timeline-wantnonselfmsgs)
474
475
    fontcombo-set $nb.g.f3.fixedfont.e $fonts(text)
476
    fontcombo-set $nb.g.f3.listboxfont.e $fonts(listbox)
477
478
    setinitialdialogfocus $nb.g.f2.usemainwin
479
480
    if [execOkCancelDialog $w] {
481
        opp_setsimoption stepdelay             [$nb.g.f1.stepdelay.e get]
482
        opp_setsimoption updatefreq_fast_ms    [$nb.g.f1.updfreq_fast.e get]
483
        opp_setsimoption updatefreq_express_ms [$nb.g.f1.updfreq_express.e get]
484
        set n [$nb.g.f2.numlines.e get]
485
        if {$n=="" || [string is integer $n]} {
486
            if {$n!="" && $n<500} {set n 500}
487
            set config(logwindow-scrollbacklines) $n
488
        }
489
        opp_setsimoption use_mainwindow      $opp(usemainwin)
490
        opp_setsimoption event_banners       $opp(eventbanners)
491
        opp_setsimoption init_banners        $opp(initbanners)
492
        opp_setsimoption short_banners       $opp(shortbanners)
493
        opp_setsimoption animation_enabled   $opp(anim)
494
        set config(concurrent-anim)          $opp(concanim)
495
        opp_setsimoption nexteventmarkers    $opp(nextev)
496
        opp_setsimoption senddirect_arrows   $opp(sdarrows)
497
        opp_setsimoption anim_methodcalls    $opp(animmeth)
498
        opp_setsimoption methodcalls_delay   $opp(methdelay)
499
        opp_setsimoption animation_msgnames  $opp(msgnam)
500
        opp_setsimoption animation_msgclassnames $opp(msgclass)
501
        opp_setsimoption animation_msgcolors $opp(msgcol)
502
        set old_iconminsize [opp_getsimoption iconminsize]
503
        opp_setsimoption iconminsize         [$nb.l.f2.iconminsize.e get]
504
        opp_setsimoption penguin_mode        $opp(penguin)
505
        opp_setsimoption showlayouting       $opp(layouting)
506
        opp_setsimoption layouterchoice      $opp(layouterchoice)
507
        opp_setsimoption arrangevectorconnections  $opp(arrangevectorconnections)
508
        opp_setsimoption bubbles             $opp(bubbles)
509
        opp_setsimoption animation_speed     $opp(speed)
510
        set config(confirm-exit)             $opp(confirmexit)
511
        set config(layout-may-resize-window) $opp(allowresize)
512
        set config(layout-may-change-zoom)   $opp(allowzoom)
513
514
        setIfPatternIsValid config(timeline-msgnamepattern)  [$nb.t.tlnamepattern.e get]
515
        setIfPatternIsValid config(timeline-msgclassnamepattern) [$nb.t.tlclassnamepattern.e get]
516
        set config(timeline-wantselfmsgs)    $opp(timeline-wantselfmsgs)
517
        set config(timeline-wantnonselfmsgs) $opp(timeline-wantnonselfmsgs)
518
519
        set font [actualFont [fixupFontName [$nb.g.f3.fixedfont.e get]]]
520
        if {$font != ""} {
521
            set fonts(text) $font
522
            applyFont Text $font
523
        }
524
525
        set font [actualFont [fixupFontName [$nb.g.f3.listboxfont.e get]]]
526
        if {$font != ""} {
527
            set fonts(listbox) $font
528
            applyFont Listbox $font
529
            applyFont TreeView $font  ;# BTL treeview
530
        }
531
        if {$old_iconminsize != [opp_getsimoption iconminsize]} {
532
            #TODO redraw all graphical inspectors
533
        }
534
        opp_updateinspectors
535
        redraw_timeline
536
    }
537
    destroy $w
538
}
539
540
proc setIfPatternIsValid {var pattern} {
541
    if [catch {opp_checkpattern $pattern} errmsg] {
542
        tk_messageBox -type ok -icon warning -title Tkenv -message "Filter pattern \"$pattern\" has invalid syntax -- setting unchanged."
543
    } else {
544
        uplevel [list set $var $pattern]
545
    }
546
}
547
548
proc rununtil_dialog {time_var event_var msg_var mode_var} {
549
550
    global opp config tmp
551
552
    upvar $time_var time_var0
553
    upvar $event_var event_var0
554
    upvar $msg_var msg_var0
555
    upvar $mode_var mode_var0
556
557
    set w .rununtil
558
    createOkCancelDialog $w {Run until}
559
560
    # collect FES messages for combo
561
    set msglabels {""}
562
    set msgptrs [opp_fesmsgs 1000 1 1 "" ""]
563
    foreach ptr $msgptrs {
564
        set msglabel "[opp_getobjectfullname $ptr] ([opp_getobjectshorttypename $ptr]), [opp_getobjectinfostring $ptr] -- $ptr"
565
        lappend msglabels $msglabel
566
    }
567
568
    # create and pack controls
569
    label-entry $w.f.time  {Simulation time to stop at:}
570
    label-entry $w.f.event {Event number to stop at:}
571
    label-combo $w.f.msg   {Message to stop at:} $msglabels
572
    label-check $w.f.stop  {} {stop if message gets cancelled} tmp(stop)
573
    label-combo $w.f.mode  {Running mode:}  {{Normal} {Fast (rare updates)} {Express (tracing off)}}
574
575
    foreach i {time event msg stop mode} {
576
       $w.f.$i.l configure -width 24
577
       pack $w.f.$i -anchor w -fill x
578
    }
579
580
    pack $w.f -anchor center -expand 1 -fill both -padx 10 -pady 10 -side top
581
582
    # restore last values
583
    set lastmsg $config(rununtil-msg)
584
    if {[lsearch -exact $msgptrs $lastmsg]==-1} {
585
        set msglabel ""  ;# saved msg pointer not currently scheduled, forget it (object may not even exist any more)
586
    } else {
587
        set msglabel "[opp_getobjectfullname $lastmsg] ([opp_getobjectshorttypename $lastmsg]), [opp_getobjectinfostring $lastmsg] -- $lastmsg"
588
    }
589
590
    $w.f.time.e insert 0 $config(rununtil-time)
591
    $w.f.event.e insert 0 $config(rununtil-event)
592
    $w.f.msg.e configure -value $msglabel
593
    $w.f.mode.e configure -value $config(rununtil-mode)
594
    set tmp(stop) [opp_getsimoption stoponmsgcancel]
595
596
    $w.f.time.e select range 0 end
597
    $w.f.event.e select range 0 end
598
599
    setinitialdialogfocus $w.f.time.e
600
601
    if [execOkCancelDialog $w] {
602
        set time_var0  [$w.f.time.e get]
603
        set event_var0 [$w.f.event.e get]
604
        set msg_var0   [lindex [$w.f.msg.e get] end]
605
        set mode_var0  [lindex [$w.f.mode.e cget -value] 0]
606
607
        set config(rununtil-time)  $time_var0
608
        set config(rununtil-event) $event_var0
609
        set config(rununtil-msg)   $msg_var0
610
        set config(rununtil-mode)  [$w.f.mode.e cget -value]
611
        opp_setsimoption stoponmsgcancel $tmp(stop)
612
613
        destroy $w
614
        return 1
615
    }
616
    destroy $w
617
    return 0
618
}
619
620
621
622
# findDialog --
623
#
624
proc findDialog {w} {
625
626
    global tmp config
627
628
    set tmp(case-sensitive)  $config(editor-case-sensitive)
629
    set tmp(whole-words)     $config(editor-whole-words)
630
    set tmp(regexp)          $config(editor-regexp)
631
    set tmp(backwards)       $config(editor-backwards)
632
633
    # dialog should be child of the window which contains the text widget
634
    set dlg [winfo toplevel $w].dlg
635
    if {$dlg=="..dlg"} {set dlg .dlg}
636
637
    # create dialog with OK and Cancel buttons
638
    set title "Find"
639
    createOkCancelDialog $dlg $title
640
641
    label-entry $dlg.f.find "Find string:"
642
    frame $dlg.f.opt
643
    pack $dlg.f.find -expand 0 -fill x
644
    pack $dlg.f.opt -expand 0 -fill none -anchor e
645
646
    # add entry fields
647
    checkbutton $dlg.f.opt.regexp -text {regular expression} -underline 0 -variable tmp(regexp)
648
    checkbutton $dlg.f.opt.case -text {case sensitive} -underline 0 -variable tmp(case-sensitive)
649
    checkbutton $dlg.f.opt.words -text {whole words only} -underline 0 -variable tmp(whole-words)
650
    checkbutton $dlg.f.opt.backwards -text {search backwards} -underline 7 -variable tmp(backwards)
651
652
    grid $dlg.f.opt.regexp $dlg.f.opt.case      -sticky nw
653
    grid $dlg.f.opt.words  $dlg.f.opt.backwards -sticky nw
654
655
    bind $dlg <Alt-r> [list $dlg.f.opt.regexp invoke]
656
    bind $dlg <Alt-R> [list $dlg.f.opt.regexp invoke]
657
    bind $dlg <Alt-c> [list $dlg.f.opt.case invoke]
658
    bind $dlg <Alt-C> [list $dlg.f.opt.case invoke]
659
    bind $dlg <Alt-w> [list $dlg.f.opt.words invoke]
660
    bind $dlg <Alt-W> [list $dlg.f.opt.words invoke]
661
    bind $dlg <Alt-b> [list $dlg.f.opt.backwards invoke]
662
    bind $dlg <Alt-B> [list $dlg.f.opt.backwards invoke]
663
664
    $dlg.f.find.e insert 0 $config(editor-findstring)
665
    $dlg.f.find.e select range 0 end
666
667
    setinitialdialogfocus $dlg.f.find.e
668
669
    # exec the dialog, extract its contents if OK was pressed, then delete dialog
670
    if {[execOkCancelDialog $dlg] == 1} {
671
        set findstring [$dlg.f.find.e get]
672
673
        set case $tmp(case-sensitive)
674
        set words $tmp(whole-words)
675
        set regexp $tmp(regexp)
676
        set backwards $tmp(backwards)
677
678
        set config(editor-findstring) $findstring
679
        set config(editor-case-sensitive) $case
680
        set config(editor-whole-words) $words
681
        set config(editor-regexp) $regexp
682
        set config(editor-backwards) $backwards
683
684
        destroy $dlg
685
        doFind $w $findstring $case $words $regexp $backwards
686
   }
687
   catch {destroy $dlg}
688
}
689
690
691
# findNext --
692
#
693
# find next occurrence of the string in the editor window
694
#
695
proc findNext {w} {
696
    global config
697
698
    set findstring   $config(editor-findstring)
699
    set case         $config(editor-case-sensitive)
700
    set words        $config(editor-whole-words)
701
    set regexp       $config(editor-regexp)
702
    set backwards    $config(editor-backwards)
703
704
    doFind $w $findstring $case $words $regexp $backwards
705
}
706
707
708
# doFind --
709
#
710
#
711
proc doFind {w findstring case words regexp backwards} {
712
    if {[_doFind $w $findstring $case $words $regexp $backwards] == ""} {
713
        tk_messageBox -parent [winfo toplevel $w] -title "Find" -icon warning \
714
                      -type ok -message "'$findstring' not found."
715
    }
716
}
717
718
# _doFind --
719
#
720
# Internal proc for doFind and doReplace.
721
#
722
# Finds the given string, positions the cursor after its last char,
723
# and returns the length. Returns empty string if not found.
724
#
725
proc _doFind {w findstring case words regexp backwards} {
726
727
    # remove previous highlights
728
    $w tag remove SELECT 0.0 end
729
730
    # find the string
731
    set cur "insert"
732
    set initialcur $cur
733
    while 1 {
734
        # do search
735
        if {$backwards} {
736
            if {$case && $regexp} {
737
                set cur [$w search -count length -backwards -regexp -- $findstring $cur 1.0]
738
            } elseif {$case} {
739
                set cur [$w search -count length -backwards -- $findstring $cur 1.0]
740
            } elseif {$regexp} {
741
                set cur [$w search -count length -backwards -nocase -regexp -- $findstring $cur 1.0]
742
            } else {
743
                set cur [$w search -count length -backwards -nocase -- $findstring $cur 1.0]
744
            }
745
        } else {
746
            if {$case && $regexp} {
747
                set cur [$w search -count length -regexp -- $findstring $cur end]
748
            } elseif {$case} {
749
                set cur [$w search -count length -- $findstring $cur end]
750
            } elseif {$regexp} {
751
                set cur [$w search -count length -nocase -regexp -- $findstring $cur end]
752
            } else {
753
                set cur [$w search -count length -nocase -- $findstring $cur end]
754
            }
755
        }
756
757
        # exit if not found
758
        if {$cur == ""} {
759
            break
760
        }
761
762
        # allow exit loop only if we moved from initial cursor position
763
        if {![$w compare "$cur  + $length chars" == $initialcur]} {
764
            # if 'whole words' and we are not at beginning of a word, continue searching
765
            if {!$words} {
766
                break
767
            }
768
            if {[$w compare $cur == "$cur wordstart"] && \
769
                [$w compare "$cur + $length char" == "$cur wordend"]} {
770
                break
771
            }
772
        }
773
774
        # move cur so that we find next/prev occurrence
775
        if {$backwards} {
776
            set cur "$cur - 1 char"
777
        } else {
778
            set cur "$cur + 1 char"
779
        }
780
    }
781
782
    # check if found
783
    if {$cur == ""} {
784
        return ""
785
    }
786
787
    # highlight it and return length
788
    $w tag add SELECT $cur "$cur + $length chars"
789
    $w mark set insert "$cur + $length chars"
790
    $w see insert
791
792
    return $length
793
}
794
795
#
796
# Dialog to show/hide events in log windows. Returns an updated
797
# excludedModuleIds list; or a single 0 on cancel (0 is not a valid
798
# module Id.)
799
#
800
proc moduleOutputFilterDialog {rootmodule excludedModuleIds} {
801
    global tmp tmpExcludedModuleIds
802
803
    if {[network_present] == 0} {return 0}
804
805
    set title "Filter window contents"
806
    set msg "Select modules to show log messages from:"
807
808
    set w .treedialog
809
    createOkCancelDialog $w $title
810
811
    label $w.f.m -text $msg -anchor w -justify left
812
    frame $w.f.f -bd 2 -relief sunken
813
    pack $w.f.m -fill x -padx 10 -pady 5 -side top
814
    pack $w.f.f -expand 1 -fill both -padx 10 -pady 5 -side top
815
816
    canvas $w.f.f.c -width 300 -height 350 -bd 0 -relief flat -yscrollcommand "$w.f.f.vsb set"
817
    #   -xscrollcommand "$w.f.f.hsb set"
818
    #scrollbar $w.f.f.hsb -command "$w.f.f.c xview" -orient horiz
819
    scrollbar $w.f.f.vsb -command "$w.f.f.c yview"
820
    grid $w.f.f.c   $w.f.f.vsb  -sticky news
821
    #grid $w.f.f.hsb x           -sticky news
822
    grid rowconfig $w.f.f 0 -weight 1
823
    grid columnconfig $w.f.f 0 -weight 1
824
825
    set tree $w.f.f.c
826
    set tmp(moduletreeroot) $rootmodule
827
    array unset tmpExcludedModuleIds
828
    foreach i $excludedModuleIds {set tmpExcludedModuleIds($i) 1}
829
830
    Tree:init $tree getModuleTreeInfo
831
    Tree:open $tree $rootmodule
832
833
    setinitialdialogfocus $tree
834
835
    if [execOkCancelDialog $w] {
836
        set excludedModuleIds {}
837
        foreach ptr [Tree:getcheckvars $tree] {
838
            set varname [Tree:getcheckvar $tree $ptr]
839
            upvar #0 $varname checkboxvar
840
            set isExcluded [expr !$checkboxvar]
841
            if {$isExcluded} {
842
                set moduleId [opp_getobjectid $ptr]
843
                lappend excludedModuleIds $moduleId
844
            }
845
        }
846
        array unset tmpExcludedModuleIds
847
        destroy $w
848
        return $excludedModuleIds
849
    }
850
    array unset tmpExcludedModuleIds
851
    destroy $w
852
    return 0
853
}
854
855
proc getModuleTreeInfo {w op {key {}}} {
856
    global icons tmp tmpExcludedModuleIds
857
858
    set ptr $key
859
    switch $op {
860
861
      text {
862
        set id [opp_getobjectid $ptr]
863
        if {$id!=""} {set id " (id=$id)"}
864
        return "[opp_getobjectfullname $ptr] ([opp_getobjectshorttypename $ptr])$id"
865
      }
866
867
      needcheckbox {
868
        # we're going to say "yes", but initialize checkbox state first
869
        set varname [Tree:getcheckvar $w $ptr]
870
        upvar #0 $varname checkboxvar
871
        if {![info exist checkboxvar]} {
872
            set moduleId [opp_getobjectid $ptr]
873
            set isExcluded [info exist tmpExcludedModuleIds($moduleId)]
874
            set checkboxvar [expr !$isExcluded]
875
        }
876
        return 1
877
      }
878
879
      options {
880
        return ""
881
      }
882
883
      icon {
884
        #return [get_icon_for_object $ptr]
885
        return ""
886
      }
887
888
      haschildren {
889
        if {$ptr=="treeroot"} {return 1}
890
        return [opp_hassubmodules $ptr]
891
      }
892
893
      children {
894
        if {$ptr=="treeroot"} {return $tmp(moduletreeroot)}
895
        return [opp_getsubmodules $ptr]
896
      }
897
898
      root {
899
        return "treeroot"
900
      }
901
    }
902
}
903
904
905
906
907
# filteredobjectlist_window --
908
#
909
# Implements the "Find/inspect objects" dialog.
910
#
911
proc filteredobjectlist_window {{ptr ""}} {
912
    global config tmp icons help_tips helptexts
913
    global HAVE_BLT B2 B3
914
915
    set w .objdlg
916
917
    if {$ptr==""} {set ptr [opp_object_simulation]}
918
919
    # if already exists, update the "search in" field and show it
920
    if {[winfo exists $w]} {
921
        $w.f.filter.searchin.e delete 0 end
922
        $w.f.filter.searchin.e insert 0 [opp_getobjectfullpath $ptr]
923
        show_window $w  ;# black magic to raise the window
924
        return
925
    }
926
927
    # otherwise create
928
    createCloseDialog $w "Find/inspect objects"
929
930
    # Create toolbar
931
    frame $w.toolbar -relief raised -borderwidth 1
932
    pack $w.toolbar -anchor center -expand 0 -fill x -side top -before $w.f
933
    foreach i {
934
      {sep1     -separator}
935
      {step     -image $icons(step)    -command {one_step}}
936
      {run      -image $icons(run)     -command {run_normal}}
937
      {fastrun  -image $icons(fast)    -command {run_fast}}
938
      {exprrun  -image $icons(express) -command {run_express}}
939
      {until    -image $icons(until)   -command {run_until}}
940
      {sep2     -separator}
941
      {stop     -image $icons(stop)    -command {stop_simulation}}
942
    } {
943
      set b [eval iconbutton $w.toolbar.$i]
944
      pack $b -anchor n -expand 0 -fill none -side left -padx 0 -pady 2
945
    }
946
947
    set help_tips($w.toolbar.step)    {Execute one event (F4)}
948
    set help_tips($w.toolbar.run)     {Run with full animation (F5)}
949
    set help_tips($w.toolbar.fastrun) {Run faster: no animation and rare inspector updates (F6)}
950
    set help_tips($w.toolbar.exprrun) {Run at full speed: no text output, animation or inspector updates (F7)}
951
    set help_tips($w.toolbar.until)   {Run until time or event number}
952
    set help_tips($w.toolbar.stop)    {Stop running simulation (F8)}
953
954
955
    # vars
956
    set tmp(class)    $config(filtobjlist-class)
957
    set tmp(name)     $config(filtobjlist-name)
958
    set tmp(order)    $config(filtobjlist-order)
959
    set tmp(category) $config(filtobjlist-category)
960
961
    # two panels: $w.f.filter is the upper panel for filters, and
962
    # $w.f.main is the lower one with the listbox.
963
964
    # panel for filters
965
    frame $w.f.filter
966
    pack $w.f.filter -anchor center -expand 0 -fill x -side top
967
968
    #label $w.f.filter.title -text "Filter list of all objects in the simulation:" -justify left -anchor w
969
    #pack $w.f.filter.title -anchor w -expand 1 -fill x -side top
970
971
    label-entry $w.f.filter.searchin "Search inside:" [opp_getobjectfullpath $ptr]
972
    pack $w.f.filter.searchin -anchor w -expand 0 -fill x -side top
973
974
    labelframe $w.f.filter.pars -text "Search by class and object name:"
975
    pack $w.f.filter.pars -anchor center -expand 0 -fill x -side top
976
    set fp $w.f.filter.pars
977
978
    labelwithhelp $fp.classlabel "Class filter expression:" $helptexts(filterdialog-classnamepattern)
979
    labelwithhelp $fp.namelabel  "Object full path filter, e.g. \"*.queue\ AND not length(0)\":" $helptexts(filterdialog-namepattern)
980
981
    combo $fp.classentry [concat {{}} [getClassNames]]
982
    $fp.classentry.entry config -textvariable tmp(class)
983
    entry $fp.nameentry -textvariable tmp(name)
984
985
    set help_tips($fp.classentry.entry) $helptexts(filterdialog-classnamepattern)
986
    set help_tips($fp.nameentry) $helptexts(filterdialog-namepattern)
987
988
    button $fp.refresh -text "Refresh" -width 10 -command "filteredobjectlist_refresh $w"
989
990
    grid $fp.classlabel $fp.namelabel x           -sticky nw   -padx 5
991
    grid $fp.classentry $fp.nameentry $fp.refresh -sticky news -padx 5 -pady 3
992
    grid columnconfig $fp 0 -weight 1
993
    grid columnconfig $fp 1 -weight 3
994
995
    # category filters
996
    labelframe $w.f.filter.cat -text "Object categories:"
997
    set cf $w.f.filter.cat
998
    checkbutton $cf.modules -text "modules" -variable tmp(cat-m)
999
    checkbutton $cf.modpars -text "module parameters" -variable tmp(cat-p)
1000
    checkbutton $cf.queues -text "queues" -variable tmp(cat-q)
1001
    checkbutton $cf.statistics -text "outvectors, statistics, variables" -variable tmp(cat-s)
1002
    checkbutton $cf.messages -text "messages"  -variable tmp(cat-g)
1003
    checkbutton $cf.chansgates -text "gates, channels" -variable tmp(cat-c)
1004
    checkbutton $cf.variables -text "FSM states, variables"  -variable tmp(cat-v)
1005
    checkbutton $cf.other -text "other" -variable tmp(cat-o)
1006
    grid $cf.modules   $cf.modpars     $cf.queues     $cf.statistics  -sticky nw
1007
    grid $cf.messages  $cf.chansgates  $cf.variables  $cf.other       -sticky nw
1008
    grid columnconfigure $cf 3 -weight 1
1009
    pack $cf -anchor center -expand 0 -fill x -side top
1010
1011
    foreach {c} {m q p c s g v o} {
1012
        set tmp(cat-$c) [string match "*$c*" $tmp(category)]
1013
    }
1014
1015
    # Sorting
1016
    if {!$HAVE_BLT} {
1017
        labelframe $w.f.filter.order -text "Sorting:"
1018
        label-combo $w.f.filter.order.entry "Sort by:" {{Class} {Full name} {Name}}
1019
        $w.f.filter.order.entry.e configure -textvariable tmp(order)
1020
        pack $w.f.filter.order.entry -expand 0 -fill none -side top -anchor w
1021
        pack $w.f.filter.order -expand 0 -fill x -side top
1022
    }
1023
1024
1025
    # number of objects
1026
    label $w.f.numobj -text "Found 0 objects" -justify left -anchor w
1027
    pack $w.f.numobj -anchor w -expand 0 -fill x -side top
1028
1029
    # panel for listbox
1030
    frame $w.f.main
1031
    scrollbar $w.f.main.vsb -command "$w.f.main.list yview"
1032
    scrollbar $w.f.main.hsb -command "$w.f.main.list xview" -orient horiz
1033
    multicolumnlistbox $w.f.main.list {
1034
        {class   Class  80}
1035
        {name    Name  180}
1036
        {info    Info}
1037
        {ptr     Pointer}
1038
    } -height 200 -yscrollcommand "$w.f.main.vsb set" -xscrollcommand "$w.f.main.hsb set"
1039
1040
    grid $w.f.main.list $w.f.main.vsb -sticky news
1041
    grid $w.f.main.hsb  x             -sticky news
1042
    grid rowconfig $w.f.main 0 -weight 1
1043
    grid columnconfig $w.f.main 0 -weight 1
1044
1045
    pack $w.f.main  -anchor center -expand 1 -fill both -side top
1046
1047
    set lb $w.f.main.list
1048
1049
    set type "(default)"
1050
1051
    # leave listbox empty -- filling it with all objects might take too long
1052
1053
    # Configure dialog
1054
    $w.buttons.closebutton config -command filteredobjectlist_window_close
1055
    wm protocol $w WM_DELETE_WINDOW "$w.buttons.closebutton invoke"
1056
1057
    bind $fp.classentry.entry <Return> "$fp.refresh invoke"
1058
    bind $fp.nameentry <Return> "$fp.refresh invoke"
1059
    bind $lb <Double-Button-1> "filteredobjectlist_inspect $lb; after 500 \{raise $w; focus $lb\}"
1060
    bind $lb <Key-Return> "filteredobjectlist_inspect $lb; after 500 \{raise $w; focus $lb\}"
1061
    bind $lb <Button-$B3> "+filteredobjectlist_popup %X %Y $w"  ;# Note "+"! it appends this code to binding in widgets.tcl
1062
    bind $w <Escape> "$w.buttons.closebutton invoke"
1063
    bind_runcommands $w
1064
1065
    setinitialdialogfocus $fp.nameentry
1066
1067
}
1068
1069
#
1070
# Closes Filtered object dialog
1071
#
1072
proc filteredobjectlist_window_close {} {
1073
    global config tmp
1074
    set w .objdlg
1075
1076
    set config(filtobjlist-class)    $tmp(class)
1077
    set config(filtobjlist-name)     $tmp(name)
1078
    set config(filtobjlist-order)    $tmp(order)
1079
    set config(filtobjlist-category) $tmp(category)
1080
1081
    destroy $w
1082
}
1083
1084
# getClassNames --
1085
#
1086
# helper proc for filteredobjectlist_window
1087
#
1088
proc getClassNames {} {
1089
    set classes [opp_getchildobjects [opp_object_classes]]
1090
1091
    # get the names
1092
    set classnames {}
1093
    foreach classptr $classes {
1094
        lappend classnames [opp_getobjectfullname $classptr]
1095
    }
1096
    # add classes that are not registered
1097
    #lappend classnames ...
1098
1099
    return [lsort -dictionary $classnames]
1100
}
1101
1102
# filteredobjectlist_refresh --
1103
#
1104
# helper proc for filteredobjectlist_window
1105
#
1106
proc filteredobjectlist_refresh {w} {
1107
    global config tmp HAVE_BLT
1108
    global filtobjlist_state
1109
1110
    # resolve root object
1111
    set rootobjectname [$w.f.filter.searchin.e get]
1112
    if {$rootobjectname=="simulation"} {
1113
        set rootobject [opp_object_simulation]
1114
    } else {
1115
        if [catch {
1116
            set rootobject [opp_modulebypath $rootobjectname]
1117
        } err] {
1118
            tk_messageBox -title "Error" -icon error -type ok -parent $w -message "Error: $err."
1119
            return
1120
        }
1121
        if [opp_isnull $rootobject] {
1122
            tk_messageBox -title "Error" -icon error -type ok -parent $w \
1123
                -message "Please enter a module name or 'simulation' in the 'Search inside' field -- '$rootobjectname' could not be resolved."
1124
            return
1125
        }
1126
    }
1127
1128
    set tmp(category) ""
1129
    set categories {m q p c s g v o}
1130
    foreach {c} $categories {
1131
        if {$tmp(cat-$c)} {set tmp(category) "$tmp(category)$c"}
1132
    }
1133
    if {[string length $tmp(category)]==[llength $categories]} {
1134
        set tmp(category) "a$tmp(category)"
1135
    }
1136
1137
    set class $tmp(class)
1138
    if {$class==""} {set class "*"}
1139
    if [catch {opp_checkpattern $class} errmsg] {
1140
        tk_messageBox -parent $w -type ok -icon warning -title Tkenv -message "Class filter pattern \"$class\" has invalid syntax -- using \"*\" instead."
1141
        set class "*"
1142
    }
1143
1144
    set name $tmp(name)
1145
    if {$name==""} {set name "*"}
1146
    if [catch {opp_checkpattern $name} errmsg] {
1147
        tk_messageBox -parent $w -type ok -icon warning -title Tkenv -message "Name filter pattern \"$name\" has invalid syntax -- using \"*\" instead."
1148
        set name "*"
1149
    }
1150
1151
    if {!$HAVE_BLT} {
1152
        set order $tmp(order)
1153
    } else {
1154
        set order ""
1155
    }
1156
1157
    # get list
1158
    set maxcount $config(filtobjlist-maxcount)
1159
    if [catch {
1160
        set objlist [opp_getsubobjectsfilt $rootobject $tmp(category) $class $name $maxcount $order]
1161
    } err] {
1162
        tk_messageBox -title "Error" -icon error -type ok -parent $w -message "Error: $err."
1163
        set objlist {}
1164
    }
1165
    set num [llength $objlist]
1166
1167
    # ask user if too many...
1168
    set viewall "ok"
1169
    if {$num==$maxcount} {
1170
        set viewall [tk_messageBox -title "Too many objects" -icon warning -type okcancel -parent $w \
1171
        -message "Your query matched at least $num objects, click OK to display them."]
1172
    }
1173
1174
    # clear listbox
1175
    set lb $w.f.main.list
1176
    multicolumnlistbox_deleteall $lb
1177
1178
    # insert into listbox
1179
    if {$viewall=="ok"} {
1180
        if {$num==$maxcount} {
1181
            $w.f.numobj config -text "The first $num objects found:"
1182
        } else {
1183
            $w.f.numobj config -text "Found $num objects:"
1184
        }
1185
        foreach ptr $objlist {
1186
            multicolumnlistbox_insert $lb $ptr [list ptr $ptr class [opp_getobjectshorttypename $ptr] name [opp_getobjectfullpath $ptr] info [opp_getobjectinfostring $ptr]] [get_icon_for_object $ptr]
1187
        }
1188
        set filtobjlist_state(outofdate) 0
1189
        #$lb selection set 0
1190
    }
1191
}
1192
1193
set filtobjlist_state(outofdate) 0
1194
1195
#
1196
# Called from inspectorupdate_callback whenever inspectors should be refereshed
1197
#
1198
proc filteredobjectlist_inspectorupdate {} {
1199
    global filtobjlist_state
1200
    set filtobjlist_state(outofdate) 1
1201
}
1202
1203
proc filteredobjectlist_isnotsafetoinspect {} {
1204
    global filtobjlist_state
1205
    if {$filtobjlist_state(outofdate) || [is_running]} {
1206
        return 1
1207
    }
1208
    return 0
1209
}
1210
1211
# filteredobjectlist_popup --
1212
#
1213
# helper procedure for filteredobjectlist_window -- creates popup menu
1214
#
1215
proc filteredobjectlist_popup {X Y w} {
1216
    set lb $w.f.main.list
1217
    set ptr [lindex [multicolumnlistbox_curselection $lb] 0]
1218
    if {$ptr==""} return
1219
    set insptypes [opp_supported_insp_types $ptr]
1220
1221
    set p $w.popup
1222
    catch {destroy $p}
1223
    menu $p -tearoff 0
1224
    if {[filteredobjectlist_isnotsafetoinspect]} {set state "disabled"} else {set state "normal"}
1225
    foreach type $insptypes {
1226
       $p add command -label "$type..." -state $state -command "opp_inspect $ptr \{$type\}; after 500 \{catch \{raise $w; focus $lb\}\}"
1227
    }
1228
    $p post $X $Y
1229
}
1230
1231
proc filteredobjectlist_inspect {lb} {
1232
    set w .objdlg
1233
    if {[filteredobjectlist_isnotsafetoinspect]} {
1234
        if {[is_running]} {
1235
            set advice "please stop the simulation and click Refresh first"
1236
        } else {
1237
            set advice "please click Refresh first"
1238
        }
1239
        tk_messageBox -parent $w -icon info -type ok -title {Filtered object list} \
1240
                      -message "Dialog contents might be out of date -- $advice."
1241
        return
1242
    }
1243
1244
    inspect_item_in $lb
1245
}
1246
1247
#----
1248
1249
set helptexts(timeline-namepattern) {
1250
Generic filter expression which matches the object name by default.
1251
1252
Wildcards ("?", "*") are allowed. "{a-exz}" matches any character in the
1253
range "a".."e", plus "x" and "z". You can match numbers: "job{128..191}"
1254
will match "job128", "job129", ..., "job191". "job{128..}" and "job{..191}"
1255
are also understood. You can combine patterns with AND, OR and NOT and
1256
parentheses (lowercase and, or, not are also OK). You can match against
1257
other object fields such as message length, message kind, etc., with the
1258
syntax "fieldname(pattern)". Put quotation marks around a pattern if it
1259
contains parentheses.
1260
1261
Examples:
1262
 m*
1263
            matches any object whose name begins with "m"
1264
 m* AND *-{0..250}
1265
            matches any object whose name begins with "m" and ends with dash
1266
            and a number between 0 and 250
1267
 not *timer*
1268
            matches any object whose name doesn't contain the substring "timer"
1269
 not (*timer* or *timeout*)
1270
            matches any object whose name doesn't contain either "timer" or
1271
            "timeout"
1272
 kind(3) or kind({7..9})
1273
            matches messages with message kind equal to 3, 7, 8 or 9
1274
 className(IP*) and data-*
1275
            matches objects whose class name begins with "IP" and name begins
1276
            with "data-"
1277
 not className(cMessage) and byteLength({1500..})
1278
            matches objects whose class is not cMessage, and byteLength is
1279
            at least 1500
1280
 "or" or "and" or "not" or "*(*" or "msg(ACK)"
1281
            quotation marks needed when pattern is a reserved word or contains
1282
            parentheses. (Note: msg(ACK) without parens would be interpreted
1283
            as some object having a "msg" attribute with the value "ACK"!)
1284
}
1285
1286
set helptexts(timeline-classnamepattern) {
1287
Generic filter expression which matches the class name by default.
1288
1289
Wildcards ("?", "*"), AND, OR, NOT and field matchers are accepted;
1290
see Name Filter help for a more complete list.
1291
1292
Examples:
1293
  PPPFrame
1294
            matches objects whose class name is PPPFrame
1295
  Ethernet*Frame or PPPFrame
1296
            matches objects whose class name is PPPFrame or
1297
            Ethernet(something)Frame
1298
  not cMessage
1299
            matches objects whose class name is not cMessage (so PPPFrame
1300
            etc. are accepted)
1301
  cMessage and kind(3)
1302
            matches objects of class cMessage and message kind 3.
1303
}
1304
1305
set helptexts(filterdialog-namepattern) {
1306
Generic filter expression which matches the object full path by default.
1307
1308
Wildcards ("?", "*") are allowed. "{a-exz}" matches any character in the
1309
range "a".."e", plus "x" and "z". You can match numbers: "*.job{128..191}"
1310
will match objects named "job128", "job129", ..., "job191". "job{128..}"
1311
and "job{..191}" are also understood. You can combine patterns with AND, OR
1312
and NOT and parentheses (lowercase and, or, not are also OK). You can match
1313
against other object fields such as queue length, message kind, etc., with
1314
the syntax "fieldname(pattern)". Put quotation marks around a pattern if it
1315
contains parentheses.
1316
1317
HINT: You'll want to start the pattern with "*." in most cases, to match
1318
objects anywhere in the network!
1319
1320
Examples:
1321
 *.destAddr
1322
            matches all objects whose name is "destAddr" (likely module
1323
            parameters)
1324
 *.subnet2.*.destAddr
1325
            matches objects named "destAddr" inside "subnet2"
1326
 *.node[8..10].*
1327
            matches anything inside module node[8], node[9] and node[10]
1328
 className(cQueue) and not length(0)
1329
            matches non-empty queue objects
1330
 className(cQueue) and length({10..})
1331
            matches queue objects with length>=10
1332
 kind(3) or kind({7..9})
1333
            matches messages with message kind equal to 3, 7, 8 or 9
1334
            (Only messages have a "kind" attribute.)
1335
 className(IP*) and *.data-*
1336
            matches objects whose class name begins with "IP" and
1337
            name begins with "data-"
1338
 not className(cMessage) and byteLength({1500..})
1339
            matches messages whose class is not cMessage, and byteLength is
1340
            at least 1500. (Only messages have a "byteLength" attribute.)
1341
 "*(*" or "*.msg(ACK)"
1342
            quotation marks needed when pattern is a reserved word or contains
1343
            parentheses. (Note: *.msg(ACK) without parens would be interpreted
1344
            as some object having a "*.msg" attribute with the value "ACK"!)
1345
}
1346
1347
set helptexts(filterdialog-classnamepattern) {
1348
Generic filter expression which matches class name by default.
1349
1350
Wildcards ("?", "*"), AND, OR, NOT and field matchers are accepted;
1351
see Object Filter help for a more complete list.
1352
1353
Examples:
1354
  cQueue
1355
            matches cQueue objects
1356
  TCP* or (IP* and not IPDatagram)
1357
            matches objects whose class name begins with TCP or IP,
1358
            excluding IPDatagrams
1359
  cMessage and kind(3)
1360
            matches objects of class cMessage and message kind 3.
1361
}
1362
1363
proc modelinfo_dialog {{w ""}} {
1364
    if {[network_present] == 0} {return 0}
1365
1366
    if {$w==""} {
1367
        set modptr [opp_object_systemmodule]
1368
    } else {
1369
        regexp {\.(ptr.*)-[0-9]+} $w match modptr
1370
    }
1371
    if {$modptr==[opp_object_systemmodule]} {
1372
        set what "Network"
1373
    } else {
1374
        set what "Module"
1375
    }
1376
    set modname [opp_getobjectfullpath $modptr]
1377
    set typeptrs [opp_getcomponenttypes $modptr]
1378
1379
    set msg "$what \"$modname\" uses the following simple modules:\n\n"
1380
1381
    set unspec 0
1382
    set inval 0
1383
    set isapl [opp_isapl]
1384
    foreach typeptr $typeptrs {
1385
        set typename [opp_getobjectfullname $typeptr]
1386
        set lc [opp_getobjectfield $typeptr lcprop]
1387
        if {$lc=="omnetpp"} {
1388
            append msg "  $typename   (part of OMNeT++)\n"
1389
        } else {
1390
            if {$isapl} {
1391
                if {$lc==""} {
1392
                    set lc "UNSPECIFIED*"; set unspec 1
1393
                } elseif {[string first $lc "GPL LGPL BSD"]==-1} {
1394
                    set lc "$lc - INVALID LICENSE*"; set inval 1
1395
                }
1396
            } else {
1397
                if {$lc==""} {
1398
                    set lc "unspecified*"; set unspec 1
1399
                }
1400
            }
1401
            append msg "  $typename   (license: $lc)\n"
1402
        }
1403
    }
1404
    if {$isapl && $unspec} {
1405
        append msg "\nModule licenses may be declared in the package.ned file, with @license(<license>). OMNeT++ recognizes the following licenses: GPL, LGPL, BSD.\n"
1406
    } elseif {$unspec} {
1407
        append msg "\nModule licenses may be optionally declared in the package.ned file, with @license(<license>). OMNeT++ recognizes the following open-source licenses: GPL, LGPL, BSD. Other license codes (e.g. proprietary ones) are also accepted.\n"
1408
    } elseif {$inval} {
1409
        append msg "\nOMNeT++ recognizes the following license codes in @license(): GPL, LGPL, BSD. The commercial version OMNEST accepts any license declaration.\n"
1410
    } else {
1411
        append msg "\nModule licenses are declared in package.ned, with @license(<license>).\n"
1412
    }
1413
1414
    global fonts
1415
    set dlg $w.dlg
1416
    catch {destroy $dlg}
1417
    createOkCancelDialog $dlg "Model Information"
1418
    $dlg.f config -border 0
1419
    message $dlg.f.txt -text $msg -font $fonts(normal) -width 400
1420
    pack $dlg.f.txt -expand 1 -fill both
1421
    destroy $dlg.buttons.cancelbutton
1422
    execOkCancelDialog $dlg
1423
    destroy $dlg
1424
}