Eskil

Check-in [856cc9d994]
Login

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Use PsDebug for backdoor menu
Downloads: Tarball | ZIP archive
Timelines: family | ancestors | trunk
Files: files | file ages | folders
SHA3-256: 856cc9d99437b1548387d5374ef5a0f37aaf952d77a813bd95509dcd03d55c11
User & Date: peter 2025-05-31 19:29:05.014
Context
2025-05-31
19:29
Use PsDebug for backdoor menu Leaf check-in: 856cc9d994 user: peter tags: trunk
2024-10-02
19:05
debugMenu can append check-in: 545940abe0 user: peter tags: trunk
Changes
Unified Diff Ignore Whitespace Patch
Changes to Makefile.
︙︙
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31

TCLKIT_MAC     = $(TCLKIT)/tclkit-mac-867

# Paths to the libraries used.
# If you do not have access to all these, you can get them from an Eskil kit
# as explained below.
TEXTSEARCH = /home/$(USER)/src/textsearch
DIFFUTIL   = /home/$(USER)/src/DiffUtilTcl/lib.vfs/DiffUtil
WCB        = /home/$(USER)/src/packages/wcb3.8
PDF4TCL    = /home/$(USER)/src/pdf4tcl/pkg
SNIT       = /home/$(USER)/src/packages/tcllib/modules/snit
TABLELIST  = /home/$(USER)/src/packages/tablelist6.22
TWAPI      = /home/$(USER)/src/packages/twapi
TKDND      = /home/$(USER)/src/packages/tkdnd/lib/tkdnd2.4
EMBEDFONT  = /usr/share/fonts/truetype/liberation/LiberationMono-Regular.ttf

# Tools
NAGELFAR    = nagelfar









|


|








14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31

TCLKIT_MAC     = $(TCLKIT)/tclkit-mac-867

# Paths to the libraries used.
# If you do not have access to all these, you can get them from an Eskil kit
# as explained below.
TEXTSEARCH = /home/$(USER)/src/textsearch
DIFFUTIL   = /home/$(USER)/src/DiffUtilTcl/lib.vfs/DiffUtil
WCB        = /home/$(USER)/src/packages/wcb4.1.1
PDF4TCL    = /home/$(USER)/src/pdf4tcl/pkg
SNIT       = /home/$(USER)/src/packages/tcllib/modules/snit
TABLELIST  = /home/$(USER)/src/packages/tablelist7.4.1
TWAPI      = /home/$(USER)/src/packages/twapi
TKDND      = /home/$(USER)/src/packages/tkdnd/lib/tkdnd2.4
EMBEDFONT  = /usr/share/fonts/truetype/liberation/LiberationMono-Regular.ttf

# Tools
NAGELFAR    = nagelfar
︙︙
178
179
180
181
182
183
184


185
186
187
188
189
190
191

	@echo Checking...
	@for i in $(CHKFILES); do $(NAGELFAR)  $(NAGELFARFLAGS) eskil_h.syntax $$i ; done

test:
	@./tests/all.tcl $(TESTFLAGS)

run:


	$(TCLKIT_LINUX) eskil.vfs/main.tcl -debug

#----------------------------------------------------------------
# Coverage
#----------------------------------------------------------------

# Source files for code coverage








>
>








178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193

	@echo Checking...
	@for i in $(CHKFILES); do $(NAGELFAR)  $(NAGELFARFLAGS) eskil_h.syntax $$i ; done

test:
	@./tests/all.tcl $(TESTFLAGS)

run:
	$(TCLKIT_LINUX) eskil.vfs/main.tcl
rund:
	$(TCLKIT_LINUX) eskil.vfs/main.tcl -debug

#----------------------------------------------------------------
# Coverage
#----------------------------------------------------------------

# Source files for code coverage
︙︙
Changes to eskil.vfs/lib/psballoon-1.3.tm.
︙︙
137
138
139
140
141
142
143

144
145
146
147
148
149
150

        bind $W <Button> ""
        bind $W <Leave> ""
        bind $W <Motion> ""
        return
    }

    bind $W <Enter> {

        set ::psballoon::balloon(pending) 1
        set ::psballoon::balloon(created) 0
        set ::psballoon::balloon(lastX) %X
        set ::psballoon::balloon(lastY) %Y
        set ::psballoon::balloon(id) [after 500 {psballoon::createBalloon %W %x %y}]
    }
    bind $W <Button> {








>








137
138
139
140
141
142
143
144
145
146
147
148
149
150
151

        bind $W <Button> ""
        bind $W <Leave> ""
        bind $W <Motion> ""
        return
    }

    bind $W <Enter> {
        psballoon::killBalloon
        set ::psballoon::balloon(pending) 1
        set ::psballoon::balloon(created) 0
        set ::psballoon::balloon(lastX) %X
        set ::psballoon::balloon(lastY) %Y
        set ::psballoon::balloon(id) [after 500 {psballoon::createBalloon %W %x %y}]
    }
    bind $W <Button> {
︙︙
Changes to eskil.vfs/lib/psdebug-1.0.tm.
︙︙
15
16
17
18
19
20
21

22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42







43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71

#  namespace import ::_PsDebug::*
#----------------------------------------------------------------------

package provide psdebug 1.0

namespace eval ::_PsDebug {
    variable allcmds

    namespace export debugMenu
}

#-----------------------------------------------------------------------------
# Misc useful stuff
#-----------------------------------------------------------------------------

proc ::_PsDebug::dumpMyMemUsage {str} {
    try {
        set xx [exec ps --pid [pid] --format vsize]
        set mem 0
        regexp {\d+} $xx mem
        puts "$str : memory usage $mem"
    } on error {} {
        puts "$str : memory usage unknown, call to ps failed"
    }
}

#-----------------------------------------------------------------------------
# Tracing
#-----------------------------------------------------------------------------








proc ::_PsDebug::TRenter {cmd op} {
    set fr [info frame -2]
    set line X
    if {[dict exists $fr line]} {
        set line [dict get $fr line]
    }
    puts "Line $line Enter: '$cmd'"
}
proc ::_PsDebug::TRenterstep {cmd op} {
    set fr [info frame -2]
    set line X
    if {[dict exists $fr line]} {
        set line [dict get $fr line]
    }
    puts "Line $line  Enterstep: '$cmd'"
}
proc ::_PsDebug::TRleave {cmd code res op} {
    puts "Leave: '$res'"
}
proc ::_PsDebug::TRleavestep {cmd code res op} {
    puts "Leavestep: '$res'"
}
proc ::_PsDebug::TR {cmd {step 0}} {
    TRoff $cmd
    trace add execution $cmd enter ::_PsDebug::TRenter
    trace add execution $cmd leave ::_PsDebug::TRleave
    if {$step} {
        trace add execution $cmd enterstep ::_PsDebug::TRenterstep








>
|




















>
>
>
>
>
>
>



|

|

|



|

|

|


|


|








15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79

#  namespace import ::_PsDebug::*
#----------------------------------------------------------------------

package provide psdebug 1.0

namespace eval ::_PsDebug {
    variable allcmds
    variable backdoor
    namespace export debugMenu backDoor
}

#-----------------------------------------------------------------------------
# Misc useful stuff
#-----------------------------------------------------------------------------

proc ::_PsDebug::dumpMyMemUsage {str} {
    try {
        set xx [exec ps --pid [pid] --format vsize]
        set mem 0
        regexp {\d+} $xx mem
        puts "$str : memory usage $mem"
    } on error {} {
        puts "$str : memory usage unknown, call to ps failed"
    }
}

#-----------------------------------------------------------------------------
# Tracing
#-----------------------------------------------------------------------------

proc ::_PsDebug::Limit {str} {
    if {[string length $str] > 50} {
        set str [string range $str 0 50]...
    }
    return $str
}

proc ::_PsDebug::TRenter {cmd op} {
    set fr [info frame -2]
    set lineNo X
    if {[dict exists $fr line]} {
        set lineNo [dict get $fr line]
    }
    puts "Line $lineNo Enter: '[Limit $cmd]'"
}
proc ::_PsDebug::TRenterstep {cmd op} {
    set fr [info frame -2]
    set lineNo X
    if {[dict exists $fr line]} {
        set lineNo [dict get $fr line]
    }
    puts "Line $lineNo  Enterstep: '[Limit $cmd]'"
}
proc ::_PsDebug::TRleave {cmd code res op} {
    puts "Leave: '[Limit $res]'"
}
proc ::_PsDebug::TRleavestep {cmd code res op} {
    puts "Leavestep: '[Limit $res]'"
}
proc ::_PsDebug::TR {cmd {step 0}} {
    TRoff $cmd
    trace add execution $cmd enter ::_PsDebug::TRenter
    trace add execution $cmd leave ::_PsDebug::TRleave
    if {$step} {
        trace add execution $cmd enterstep ::_PsDebug::TRenterstep
︙︙
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104


proc ::_PsDebug::debugMenu {mW args} {
    if {"-append" in $args} {
        set dW $mW
    } else {
        set dW $mW.debug
        $mW add cascade -label "Debug" -menu $dW -underline 0
        menu $dW
    }

    if {$::tcl_platform(platform) eq "windows"} {
        $dW add checkbutton -label "Console" -variable ::consoleState \
                -onvalue show -offvalue hide -command {console $::consoleState} \
                -underline 0
        $dW add separator
    }

    $dW add command -label "Edit" -command ::_PsDebug::ProcEditor \
            -underline 0
    $dW add command -label "Windows" -command ::_PsDebug::WindowBrowser \








|



|
|








93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112


proc ::_PsDebug::debugMenu {mW args} {
    if {"-append" in $args} {
        set dW $mW
    } else {
        set dW $mW.debug
        $mW add cascade -label "Debug" -menu $dW -underline 0
        menu $dW -tearoff 0
    }

    if {$::tcl_platform(platform) eq "windows"} {
        $dW add checkbutton -label "Console" -variable ::_PsDebug::consoleState \
                -onvalue show -offvalue hide -command {console $::_PsDebug::consoleState} \
                -underline 0
        $dW add separator
    }

    $dW add command -label "Edit" -command ::_PsDebug::ProcEditor \
            -underline 0
    $dW add command -label "Windows" -command ::_PsDebug::WindowBrowser \
︙︙
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130

    place [ttk::frame $top.tilebg] -border outside \
            -x 0 -y 0 -relwidth 1 -relheight 1
    wm title $top "Window Browser"
    wm protocol $top WM_DELETE_WINDOW [list ::_PsDebug::WindowBrowserClosed $top]

    ttk::panedwindow $top.pw -orient horizontal
    pack $top.pw -fill both -expand 1
    
    # Widget Tree
    ttk::frame $top.ftree
    set tree $top.ftree.tree
    ttk::treeview $tree -height 20 -selectmode browse -show "tree" \
            -yscrollcommand "$top.ftree.sby set"
    ttk::scrollbar $top.ftree.sby -orient vertical -command "$tree yview"
    $tree column "#0" -minwidth 50 -width 200








|








124
125
126
127
128
129
130
131
132
133
134
135
136
137
138

    place [ttk::frame $top.tilebg] -border outside \
            -x 0 -y 0 -relwidth 1 -relheight 1
    wm title $top "Window Browser"
    wm protocol $top WM_DELETE_WINDOW [list ::_PsDebug::WindowBrowserClosed $top]

    ttk::panedwindow $top.pw -orient horizontal
    pack $top.pw -fill both -expand 1

    # Widget Tree
    ttk::frame $top.ftree
    set tree $top.ftree.tree
    ttk::treeview $tree -height 20 -selectmode browse -show "tree" \
            -yscrollcommand "$top.ftree.sby set"
    ttk::scrollbar $top.ftree.sby -orient vertical -command "$tree yview"
    $tree column "#0" -minwidth 50 -width 200
︙︙
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192

    set values [$tree item $item -values]
    set d [lindex $values 0]
    set txt [dict get $d out]
    $::_PsDebug::WindowBrowser(textW) insert end $txt

    set interp [dict get $d interp]
    set i [list interp eval $interp]
    set w [dict get $d w]

    # A few experiments to highlight selection.
    try {
        # Overlaid frame seems to work best
        set tl [{*}$i winfo toplevel $w]
        set wx [expr [{*}$i winfo rootx $w] - [{*}$i winfo rootx $tl]]
        set wy [expr [{*}$i winfo rooty $w] - [{*}$i winfo rooty $tl]]
        set ww [{*}$i winfo width $w]
        set wh [{*}$i winfo height $w]
        set cleancmd ""
        if {$tl eq "."} {
            set tl ""
        }
        for {set t 1} {$t <= 4} {incr t} {
            set whl($t) $tl._debug_hl_$t
            destroy $whl($t)








|




|
|
|
|
|








177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200

    set values [$tree item $item -values]
    set d [lindex $values 0]
    set txt [dict get $d out]
    $::_PsDebug::WindowBrowser(textW) insert end $txt

    set interp [dict get $d interp]
    set i [list interp eval $interp]
    set W [dict get $d w]

    # A few experiments to highlight selection.
    try {
        # Overlaid frame seems to work best
        set tl [{*}$i winfo toplevel $W]
        set wx [expr {[{*}$i winfo rootx $W] - [{*}$i winfo rootx $tl]}]
        set wy [expr {[{*}$i winfo rooty $W] - [{*}$i winfo rooty $tl]}]
        set ww [{*}$i winfo width $W]
        set wh [{*}$i winfo height $W]
        set cleancmd ""
        if {$tl eq "."} {
            set tl ""
        }
        for {set t 1} {$t <= 4} {incr t} {
            set whl($t) $tl._debug_hl_$t
            destroy $whl($t)
︙︙
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251

        #puts "In $interp"
        #puts "$err"
        #puts "$info"
    }

    try {
        # Reconfiguring class. Does not work with disabled buttons e.g.
        set class [{*}$i winfo class $w]
        set oldstyle [{*}$i $w cget -style]
        if {$oldstyle eq ""} {
            set basestyle $class
        } else {
            set basestyle $oldstyle
        }
        set style HighLightRed.$basestyle
        {*}$i ttk::style configure $style -background red -fieldbackground red
        {*}$i $w configure -style $style
        set ::_PsDebug::WindowBrowser(deselect) \
                [list {*}$i [list $w configure -style $oldstyle]]
        #puts "CLASS $class STYLE $style"
        #puts [{*}$i ttk::style configure $basestyle]
        #puts [{*}$i ttk::style configure $style]
        return
    } on error {err info} {
        #puts "In $interp"
        #puts "$err"
        #puts "$info"
    }
    try {
        # Tk style background change. Only works with Tk.
        set bg [{*}$i $w cget -background]
        {*}$i $w configure -background red
        set ::_PsDebug::WindowBrowser(deselect) \
                [list {*}$i [list $w configure -background $bg]]
        return
    } on error {err info} {
        #puts "In $interp"
        #puts "$err"
        #puts "$info"
    }
    #puts "MOO $w"
}

# Format configure data from a widget for display
proc ::_PsDebug::FormatConfigure {configData} {
    set first ""
    set last ""
    foreach param $configData {








|
|







|

|











|
|

|






|








212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259

        #puts "In $interp"
        #puts "$err"
        #puts "$info"
    }

    try {
        # Reconfiguring class. Does not work with disabled buttons e.g.
        set class [{*}$i winfo class $W]
        set oldstyle [{*}$i $W cget -style]
        if {$oldstyle eq ""} {
            set basestyle $class
        } else {
            set basestyle $oldstyle
        }
        set style HighLightRed.$basestyle
        {*}$i ttk::style configure $style -background red -fieldbackground red
        {*}$i $W configure -style $style
        set ::_PsDebug::WindowBrowser(deselect) \
                [list {*}$i [list $W configure -style $oldstyle]]
        #puts "CLASS $class STYLE $style"
        #puts [{*}$i ttk::style configure $basestyle]
        #puts [{*}$i ttk::style configure $style]
        return
    } on error {err info} {
        #puts "In $interp"
        #puts "$err"
        #puts "$info"
    }
    try {
        # Tk style background change. Only works with Tk.
        set bg [{*}$i $W cget -background]
        {*}$i $W configure -background red
        set ::_PsDebug::WindowBrowser(deselect) \
                [list {*}$i [list $W configure -background $bg]]
        return
    } on error {err info} {
        #puts "In $interp"
        #puts "$err"
        #puts "$info"
    }
    #puts "MOO $W"
}

# Format configure data from a widget for display
proc ::_PsDebug::FormatConfigure {configData} {
    set first ""
    set last ""
    foreach param $configData {
︙︙
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377

    $tree delete [$tree children {}]
    set todo [list . {}]
    # Outer loop for subinterps TBD
    while {[llength $todo] > 0} {
        set containers {}
        while {[llength $todo] > 0} {
            # POP
            set w [lindex $todo 0]
            set interp [lindex $todo 1]
            set i [list interp eval $interp]
            set todo [lrange $todo 2 end]
            set long $interp$w
            if {$w in {.windowbrowser}} continue

            foreach child [lsort -dictionary [{*}$i winfo children $w]] {
                lappend todo $child $interp
            }
            set id($long) "N$long"
            if {[info exists parents($long)]} {
                # Parent passed from other interp
                set parentId $id($parents($long))
            } else {
                set parent [{*}$i winfo parent $w]
                if {$parent eq ""} {
                    set parentId ""
                } else {
                    set parentId $id($interp$parent)
                }
            }

            set class [{*}$i winfo class $w]
            # Info to be displayed
            set out "$w  ($class)\n"
            set configData [{*}$i $w configure]
            append out [FormatConfigure $configData]
            foreach param $configData {
                lassign $param flag _ _ def value
                if {$flag eq "-container" && $value == 1} {
                    lappend containers $w $interp
                }
            }
            # Add grid info, if any
            try {
                set ix [{*}$i grid info $w]
                if {$ix ne ""} {
                    append out "\n\ngrid\n$ix"
                }
            } on error {} {}
            # Add pack info, if any
            try {
                set ix [{*}$i pack info $w]
                if {$ix ne ""} {
                    append out "\n\npack\n$ix"
                }
            } on error {} {}
            # Add menu info, if menu
            try {
                set last [{*}$i $w index end]
                for {set ix 0} {$ix <= $last} {incr ix} {
                    set configData [{*}$i $w entryconfigure $ix]
                    append out \n\n [FormatConfigure $configData]
                }
            } trap {TCL LOOKUP INDEX} {} {
                # Non-menu widgets will normally error out on not having the
                # "index" subcommand, which ends up here. Ignore.
            } on error {msg erri} {
                # Give some hint on other errors
                #puts "MOOO $msg\n$erri"
            }
            
            set name $w
            regexp {\.[^.]+$} $w name

            set open 1
            if {[string match "*#*" $w]} {
                set open 0
            }

            set d {}
            dict set d w $w
            dict set d interp $interp
            dict set d id $id($long)
            dict set d out $out

            $tree insert $parentId end -id $id($long) -open $open \
                    -text $name -values [list $d]
        }
        # TODO: Handle -container and subinterp? How?
        foreach {w interp} $containers {
            set wid [winfo id $w]
            foreach sub [interp slaves $interp] {
                try {
                    set subId [interp eval $sub . cget -use]
                    if {$subId == $wid} {
                        #puts "Found interp $sub for $w"
                        set parents($sub.) $interp$w
                        lappend todo . $sub
                    }
                } on error {} {}

            }
        }
        #break








|



|
|

|







|







|

|
|




|




|






|






|

|









|
|
|


|




|









|
|



|
|








283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385

    $tree delete [$tree children {}]
    set todo [list . {}]
    # Outer loop for subinterps TBD
    while {[llength $todo] > 0} {
        set containers {}
        while {[llength $todo] > 0} {
            # POP
            set W [lindex $todo 0]
            set interp [lindex $todo 1]
            set i [list interp eval $interp]
            set todo [lrange $todo 2 end]
            set long $interp$W
            if {$W in {.windowbrowser}} continue

            foreach child [lsort -dictionary [{*}$i winfo children $W]] {
                lappend todo $child $interp
            }
            set id($long) "N$long"
            if {[info exists parents($long)]} {
                # Parent passed from other interp
                set parentId $id($parents($long))
            } else {
                set parent [{*}$i winfo parent $W]
                if {$parent eq ""} {
                    set parentId ""
                } else {
                    set parentId $id($interp$parent)
                }
            }

            set class [{*}$i winfo class $W]
            # Info to be displayed
            set out "$W  ($class)\n"
            set configData [{*}$i $W configure]
            append out [FormatConfigure $configData]
            foreach param $configData {
                lassign $param flag _ _ def value
                if {$flag eq "-container" && $value == 1} {
                    lappend containers $W $interp
                }
            }
            # Add grid info, if any
            try {
                set ix [{*}$i grid info $W]
                if {$ix ne ""} {
                    append out "\n\ngrid\n$ix"
                }
            } on error {} {}
            # Add pack info, if any
            try {
                set ix [{*}$i pack info $W]
                if {$ix ne ""} {
                    append out "\n\npack\n$ix"
                }
            } on error {} {}
            # Add menu info, if menu
            try {
                set last [{*}$i $W index end]
                for {set ix 0} {$ix <= $last} {incr ix} {
                    set configData [{*}$i $W entryconfigure $ix]
                    append out \n\n [FormatConfigure $configData]
                }
            } trap {TCL LOOKUP INDEX} {} {
                # Non-menu widgets will normally error out on not having the
                # "index" subcommand, which ends up here. Ignore.
            } on error {msg erri} {
                # Give some hint on other errors
                #puts "MOOO $msg\n$erri"
            }

            set name $W
            regexp {\.[^.]+$} $W name

            set open 1
            if {[string match "*#*" $W]} {
                set open 0
            }

            set d {}
            dict set d w $W
            dict set d interp $interp
            dict set d id $id($long)
            dict set d out $out

            $tree insert $parentId end -id $id($long) -open $open \
                    -text $name -values [list $d]
        }
        # TODO: Handle -container and subinterp? How?
        foreach {w interp} $containers {
            set wid [winfo id $W]
            foreach sub [interp children $interp] {
                try {
                    set subId [interp eval $sub . cget -use]
                    if {$subId == $wid} {
                        #puts "Found interp $sub for $W"
                        set parents($sub.) $interp$W
                        lappend todo . $sub
                    }
                } on error {} {}

            }
        }
        #break
︙︙
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439

        lassign [info class definition $parent $name] arglist body
        set traceState disabled
        set ::_PsDebug::ProcEditor(args) $arglist
        $::_PsDebug::ProcEditor(bodyW) insert end $body
    } else {
        set traceState disabled
    }
    foreach w $::_PsDebug::ProcEditor(traceWs) {
        $w configure -state $traceState
    }

}

# Redefine currently edited proc/method
proc ::_PsDebug::ProcEditorRedefine {} {
    variable allcmds








|
|








432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447

        lassign [info class definition $parent $name] arglist body
        set traceState disabled
        set ::_PsDebug::ProcEditor(args) $arglist
        $::_PsDebug::ProcEditor(bodyW) insert end $body
    } else {
        set traceState disabled
    }
    foreach W $::_PsDebug::ProcEditor(traceWs) {
        $W configure -state $traceState
    }

}

# Redefine currently edited proc/method
proc ::_PsDebug::ProcEditorRedefine {} {
    variable allcmds
︙︙
461
462
463
464
465
466
467









468
469
470
471
472
473
474


proc ::_PsDebug::ProcEditorCopy {} {
    clipboard clear
    foreach item [array names ::_PsDebug::redefines] {
        clipboard append $::_PsDebug::redefines($item)\n
    }
}










# Tracing of commands
proc ::_PsDebug::ProcEditorTrace {level} {
    variable allcmds
    set item $::_PsDebug::ProcEditor(current)
    set d $allcmds($item)
    set type [dict get $d type]








>
>
>
>
>
>
>
>
>








469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491


proc ::_PsDebug::ProcEditorCopy {} {
    clipboard clear
    foreach item [array names ::_PsDebug::redefines] {
        clipboard append $::_PsDebug::redefines($item)\n
    }
}

# Helper to start trace from code
proc ::_PsDebug::traceProc {item level} {
    variable allcmds
    # Fill in enough info to let ProcEditorTrace work.
    set ::_Debug::ProcEditor(current) $item
    set allcmds($item) [list type proc parent :: name doTemplate]
    ::_PsDebug::ProcEditorTrace $level
}

# Tracing of commands
proc ::_PsDebug::ProcEditorTrace {level} {
    variable allcmds
    set item $::_PsDebug::ProcEditor(current)
    set d $allcmds($item)
    set type [dict get $d type]
︙︙
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585



586

587
588
589
590
591
592
593

        }
        $tree insert $path end -id $cmd \
                -text [dict get $d name] -values [list $path]
    }
}

# Main Proc Editor window
proc ::_PsDebug::ProcEditor {} {
    ::_PsDebug::CollectInfo

    set top .proceditor
    destroy $top
    tk::toplevel $top -padx 3 -pady 3
    place [ttk::frame $top.tilebg] -border outside \
            -x 0 -y 0 -relwidth 1 -relheight 1



    wm title $top "Proc Editor"


    ttk::frame $top.ftree
    set ::_PsDebug::ProcEditor(filter) ""
    set ::_PsDebug::ProcEditor(filterx) ""
    ttk::entry $top.ftree.ef -textvariable ::_PsDebug::ProcEditor(filter)
    addBalloon $top.ftree.ef "Filter"
    bind $top.ftree.ef <KeyRelease> {::_PsDebug::ProcEditorFilter %A %K}








|







>
>
>
|
>








588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614

        }
        $tree insert $path end -id $cmd \
                -text [dict get $d name] -values [list $path]
    }
}

# Main Proc Editor window
proc ::_PsDebug::ProcEditor {{suffix {}}} {
    ::_PsDebug::CollectInfo

    set top .proceditor
    destroy $top
    tk::toplevel $top -padx 3 -pady 3
    place [ttk::frame $top.tilebg] -border outside \
            -x 0 -y 0 -relwidth 1 -relheight 1
    if {$suffix ne ""} {
        wm title $top "Proc Editor - $suffix"
    } else {
        wm title $top "Proc Editor"
    }

    ttk::frame $top.ftree
    set ::_PsDebug::ProcEditor(filter) ""
    set ::_PsDebug::ProcEditor(filterx) ""
    ttk::entry $top.ftree.ef -textvariable ::_PsDebug::ProcEditor(filter)
    addBalloon $top.ftree.ef "Filter"
    bind $top.ftree.ef <KeyRelease> {::_PsDebug::ProcEditorFilter %A %K}
︙︙
637
638
639
640
641
642
643

















































































644
645
646
647
648
649
650

    grid ^          $top.l3a $top.l3b - -       - -padx 3 -pady 3 -sticky we
    grid ^          $top.t  -         - -  $top.sby -padx 3 -pady 3 -sticky news
    grid ^          $top.fb -         - -  -        -padx 3 -pady 3 -sticky we

    grid columnconfigure $top 2 -weight 1
    grid rowconfigure    $top $top.t -weight 1
}


















































































#-----------------------------------------------------------------------------
# Procedure/method information collection
#-----------------------------------------------------------------------------
#
# There is nuances to namespace handling that needs awareness.
#








>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>








658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752

    grid ^          $top.l3a $top.l3b - -       - -padx 3 -pady 3 -sticky we
    grid ^          $top.t  -         - -  $top.sby -padx 3 -pady 3 -sticky news
    grid ^          $top.fb -         - -  -        -padx 3 -pady 3 -sticky we

    grid columnconfigure $top 2 -weight 1
    grid rowconfigure    $top $top.t -weight 1
}

#-----------------------------------------------------------------------------
# Debug backdoor support
# Example use:
#    backDoor . -keyword "MyDebug" -escape 1 \
#            -callback [list addDebug .]
#    Get standard debug menu with -menu 1 
#    If psmenu package is available the generated debug menu can be prepended
#    with items like this:
#        -menu {
#            "Die"           -cmd exit
#            ---
#        }
#    Callback is called after creating the menu.
#    If -escape is true, Key-Esc will be bound to setting focus on toplevel.
#    If -now is true, the effect is triggered immediately
#-----------------------------------------------------------------------------

proc ::_PsDebug::backDoor {W args} {
    variable backdoor

    set opts(-keyword) "PsDebug"
    set opts(-callback) ""
    set opts(-menu) ""
    set opts(-postmenu) ""
    set opts(-escape) 0
    set opts(-now) 0
    array set opts $args

    set top [winfo toplevel $W]
    set backdoor($top) ""
    set backdoor($top,kw) $opts(-keyword)
    set backdoor($top,cb) $opts(-callback)
    set backdoor($top,menu) $opts(-menu)
    set backdoor($top,postmenu) $opts(-postmenu)
    set backdoor($top,ix) end-[expr {[string length $opts(-keyword)] - 1}]
    
    set val [bindtags $top]
    set tag psBackDoor$top
    lappend val $tag
    bindtags $top $val
    # Keep this binding on a separate tag, so that other key
    # bindings on the top does not steal the keys
    bind $tag <Key> "::_PsDebug::BackDoorKey $top %A"
    # Go out to toplevel with escape, whereever you are
    bind $top <Key-Escape> [list focus $top]

    if {$opts(-now)} {
        set backdoor($top) $backdoor($top,kw)
        BackDoorKey $top ""
    }
}

proc ::_PsDebug::BackDoorKey {top aVal} {
    variable backdoor
    append backdoor($top) $aVal
    set backdoor($top) [string range $backdoor($top) $backdoor($top,ix) end]
    if {$backdoor($top) eq $backdoor($top,kw)} {
        # -postmenu implies -menu
        if {$backdoor($top,postmenu) ne "" && $backdoor($top,menu) eq ""} {
            set backdoor($top,menu) 1
        }
        if {$backdoor($top,menu) == 1} {
            if {$top eq "."} {
                set dW [debugMenu .m]
            } else {
                set dW [debugMenu $top.m]
            }
        } elseif {$backdoor($top,menu) ne ""} {
            psmenu::psmenu $top [string map [list % [list $backdoor($top,menu)]] {
                "&Debug" -var dW %
            }]
            debugMenu $dW -append
        }
        if {$backdoor($top,postmenu) ne ""} {
            # TBD append
            psmenu::psmenu $dW -top $top $backdoor($top,postmenu)
        }
        uplevel \#0 $backdoor($top,cb)
    }
}

#-----------------------------------------------------------------------------
# Procedure/method information collection
#-----------------------------------------------------------------------------
#
# There is nuances to namespace handling that needs awareness.
#
︙︙
Changes to eskil.vfs/lib/psmenu-1.1.tm.
︙︙
81
82
83
84
85
86
87
88


89
90
91
92
93
94
95

    }
}

##nagelfar syntax psmenu::PopEntry v
##nagelfar syntax tk::AmpMenuArgs x*

# Main call for psmenu. Some optional arguments are for internal use.
# Canbe called with an existing menu, but then -top must be given.


proc psmenu::psmenu {top args} {
    set def [lindex $args end]
    set args [lrange $args 0 end-1]

    set opts(-top) ""
    set opts(-level) ""
    set opts(-level) ""








|
>
>








81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97

    }
}

##nagelfar syntax psmenu::PopEntry v
##nagelfar syntax tk::AmpMenuArgs x*

# Main call for psmenu. Some optional arguments are for internal use.
# Can be called with an existing menu, but then -top must be given.
##nagelfar syntax psmenu::psmenu x p* x
##nagelfar ignore does not match
proc psmenu::psmenu {top args} {
    set def [lindex $args end]
    set args [lrange $args 0 end-1]

    set opts(-top) ""
    set opts(-level) ""
    set opts(-level) ""
︙︙
Changes to src/eskil.syntax.
︙︙
14
15
16
17
18
19
20


21






22
23
24
25
26
27
28


##nagelfar syntax safeLoad x n
##nagelfar syntax helpWin x x
##nagelfar syntax commonYScroll x x*
##nagelfar syntax locateEditor n
##nagelfar syntax locateTmp n
##nagelfar package known pstools


##nagelfar package known psballoon







##nagelfar syntax wcb::cancel 0
##nagelfar syntax wcb::callback 4
##nagelfar package known wcb

##nagelfar syntax ::tk::GetSelection x x
##nagelfar syntax ::tk::ScrollButton2Down x x x








>
>

>
>
>
>
>
>








14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36


##nagelfar syntax safeLoad x n
##nagelfar syntax helpWin x x
##nagelfar syntax commonYScroll x x*
##nagelfar syntax locateEditor n
##nagelfar syntax locateTmp n
##nagelfar package known pstools

##nagelfar syntax psballoon::FigureOutScreenWidths x
##nagelfar package known psballoon

##nagelfar syntax psmenu::psmenu x p* x
##nagelfar package known psmenu

##nagelfar syntax backDoor x*
##nagelfar package known psdebug

##nagelfar syntax wcb::cancel 0
##nagelfar syntax wcb::callback 4
##nagelfar package known wcb

##nagelfar syntax ::tk::GetSelection x x
##nagelfar syntax ::tk::ScrollButton2Down x x x
︙︙
Changes to src/eskil.tcl.
︙︙
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204
3205
3206
3207


3208
3209
3210
3211
3212

3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225



3226
3227
3228
3229
3230
3231
3232

    }
    wm deiconify $top
    raise $top
    update
    doDiff $top
}

# A thing to easily get to debug mode
proc backDoor {top aVal} {
    append ::eskil(backdoor) $aVal
    set ::eskil(backdoor) [string range $::eskil(backdoor) end-9 end]
    if {$::eskil(backdoor) eq "EskilDebug"} {
        set ::eskil(debug) 1
        catch {console show}
        set ::eskil(backdoor) ""
        AddDebugMenu $top
    }
}

# Runtime disable of C version of DiffUtil
proc DisableDiffUtilC {} {
    uplevel \#0 [list source $::eskil(thisDir)/../lib/diffutil/tcl/diffutil.tcl]
}

# Add a debug menu to a toplevel window
proc AddDebugMenu {top} {
    set dMenu [debugMenu $top.m]



    $dMenu add checkbutton -label "Wrap" -variable wrapstate \
        -onvalue char -offvalue none -command \
        "$::widgets($top,wDiff1) configure -wrap \$wrapstate ;\
                $::widgets($top,wDiff2) configure -wrap \$wrapstate"

    
    psmenu::psmenu $dMenu -top $top {
        ---
        "&Reread Source" -cmd EskilRereadSource
        ---
        "Normal Cursor"  -cmd "normalCursor $top"
        "Fill X"         -cmd "fillWindowX $top"
        ---
        # Runtime disable of C version of DiffUtil
        "Tcl DiffUtil" -cmd DisableDiffUtilC
        "Evalstats"    -cmd {evalstats}
        "_stats"       -cmd {parray _stats}
    }



}

# Build the main window
# "other" is related window. Currently unused
proc makeDiffWin {{other {}} args} {
    global tcl_platform









<
<
<
<
<
<
<
<
<
<
<
<





|
|
|
>
>
|
|
<
|
|
>

|
<
<




<




>
>
>








3181
3182
3183
3184
3185
3186
3187












3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199

3200
3201
3202
3203
3204


3205
3206
3207
3208

3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222

    }
    wm deiconify $top
    raise $top
    update
    doDiff $top
}













# Runtime disable of C version of DiffUtil
proc DisableDiffUtilC {} {
    uplevel \#0 [list source $::eskil(thisDir)/../lib/diffutil/tcl/diffutil.tcl]
}

# Organise a keyword to create backdoor menu
proc SetupBackDoor {top now} {
    set menu {
        "&Reread Source" -cmd EskilRereadSource
        ---
    }


    set cmd "$::widgets($top,wDiff1) configure -wrap \\\$wrapstate ;\
                $::widgets($top,wDiff2) configure -wrap \\\$wrapstate"
    set menu2 [list "Wrap" -cmd $cmd -var wrapstate -onvalue char -offvalue none]
    
    append menu2 {


        ---
        "Normal Cursor"  -cmd "normalCursor $top"
        "Fill X"         -cmd "fillWindowX $top"
        ---

        "Tcl DiffUtil" -cmd DisableDiffUtilC
        "Evalstats"    -cmd {evalstats}
        "_stats"       -cmd {parray _stats}
    }
    backDoor $top -keyword "EskilDebug" -escape 1 \
            -callback [list set ::eskil(debug) 1] \
            -menu $menu -postmenu $menu2 -now $now
}

# Build the main window
# "other" is related window. Currently unused
proc makeDiffWin {{other {}} args} {
    global tcl_platform
︙︙
3589
3590
3591
3592
3593
3594
3595

3596
3597
3598
3599
3600
3601
3602
3603
3604
3605
3606
3607
3608
3609
3610
3611
3612
3613
3614
3615
3616

        bind $top <Key-l>     [list scrollText $top xview scroll  5 u]
        bind $top <Key-Home>  [list scrollText $top yview moveto 0]
        bind $top <Key-g>     [list scrollText $top yview moveto 0]
        bind $top <Key-End>   [list scrollText $top yview moveto 1]
    }

    # Go out to toplevel with escape, whereever you are

    bind $top <Key-Escape> [list focus $top]

    if {$::eskil(debug) == 0} {
        set val [bindtags $top]
        lappend val backDoor$top
        bindtags $top $val
        # Keep this binding on a separate tag, so that other key
        # bindings on the top does not steal the keys
        bind backDoor$top <Key> "backDoor $top %A"
    }

    if {$::eskil(debug) == 1} {
        AddDebugMenu $top
    }

    resetEdit $top
    return $top
}

proc ValidateNewColors {} {
    foreach item {colorchange bgchange colornew1 bgnew1








>
|

|
<
<
<
<
<
<
<
<
<
<
<








3579
3580
3581
3582
3583
3584
3585
3586
3587
3588
3589











3590
3591
3592
3593
3594
3595
3596

        bind $top <Key-l>     [list scrollText $top xview scroll  5 u]
        bind $top <Key-Home>  [list scrollText $top yview moveto 0]
        bind $top <Key-g>     [list scrollText $top yview moveto 0]
        bind $top <Key-End>   [list scrollText $top yview moveto 1]
    }

    # Go out to toplevel with escape, whereever you are
    # Thus is handled by backdoor now
    #bind $top <Key-Escape> [list focus $top]

    SetupBackDoor $top $::eskil(debug)












    resetEdit $top
    return $top
}

proc ValidateNewColors {} {
    foreach item {colorchange bgchange colornew1 bgnew1
︙︙
Changes to src/fourway.tcl.
︙︙
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76

                -command [list cleanupAndExit all]

        $win.m add cascade -menu $win.m.mt -label "Tools" -underline 0
        menu $win.m.mt
        $win.m.mt add command -label "Changeset" -underline 0 \
                -command [mymethod changeset]

        if {$::eskil(debug) == 1} {
            AddDebugMenu $win
        }
 
        # Four files, with optional revision
        set fields {base1 change1 base2 change2}
    
        ttk::label $win.l1 -text "Base 1"
        ttk::label $win.l2 -text "Changed 1"
        ttk::label $win.l3 -text "Base 2"
        ttk::label $win.l4 -text "Changed 2"








<
<
<
<








59
60
61
62
63
64
65




66
67
68
69
70
71
72

                -command [list cleanupAndExit all]

        $win.m add cascade -menu $win.m.mt -label "Tools" -underline 0
        menu $win.m.mt
        $win.m.mt add command -label "Changeset" -underline 0 \
                -command [mymethod changeset]





        # Four files, with optional revision
        set fields {base1 change1 base2 change2}
    
        ttk::label $win.l1 -text "Base 1"
        ttk::label $win.l2 -text "Changed 1"
        ttk::label $win.l3 -text "Base 2"
        ttk::label $win.l4 -text "Changed 2"
︙︙