blob: a166a82b133c1165e075b2884e1bd5b7b1ee8fdc (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
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
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
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
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
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
|
#!/usr/bin/env tclsh
## -*- tcl -*-
##########################################################################
# TEPAM - Tcl's Enhanced Procedure and Argument Manager
##########################################################################
#
# tepam_demo.tcl:
# This file provides a graphical demo framework for the enhanced procedure
# and argument manager.
#
# Copyright (C) 2009, 2010 Andreas Drollinger
#
# Id: tepam_demo.tcl
##########################################################################
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
##########################################################################
package require Tk
package require tepam
if {$tcl_platform(platform)=={windows}} {
set Config(MenuBG_Color) "\#c0c0c0"
set Config(MenuFG_Color) "black"
} else {
set Config(MenuBG_Color) "\#667de3"
set Config(MenuFG_Color) "white"
}
######################## Regression test GUI ########################
proc DisplayResult {Result Type} {
regsub -line -all {^(.)} $Result "$Type: -> \\1" Result
regsub -line -all {[\t ]+$} $Result "" Result
.rightside.code insert insert $Result Result_$Type
# .rightside.code see insert
update
}
# Implement an own puts function that will display the provided strings inside
# the execution window.
rename puts puts_orig
proc puts {args} {
# Use the original function of the write channel if argument 0 is not a standard channel
if {[llength $args]>1 && [lindex $args 0]!="-nonewline" && [lindex $args 0]!="stdout" && [lindex $args 0]!="stderr"} {
if {[llength $args]==2} {
puts_orig [lindex $args 0] [lindex $args 1]
} else {
puts_orig [lindex $args 0] [lindex $args 1] [lindex $args 2]
}
return
}
set EndLine "\n"
if {[lindex $args end-1]=="-nonewline"} {
set EndLine ""
}
DisplayResult [lindex $args end]$EndLine s
}
# Create an exit function that will just close an eventually opened console
# window. This demo application can only be closed by calling the orginial
# exit command via the application's menu.
rename exit exit_orig
proc exit {args} {
catch {destroy .tkcon}
catch {console hide}
}
proc ExecuteExampleStep {Step} {
global ExampleScript IsExecutable ExecutedSteps
set CmdNbr 0
foreach es $ExampleScript($Step) {
.rightside.code mark set insert step$Step-cmd$CmdNbr
if {[catch {set CmdRes [uplevel #0 $es]} ErrorRes]} {
DisplayResult "$ErrorRes \n" e
} else {
DisplayResult "$CmdRes \n" r
}
incr CmdNbr
}
lappend ExecutedSteps $Step
foreach Step [array names IsExecutable] {
set Executed [expr [lsearch -exact $ExecutedSteps $Step]>=0]
if $IsExecutable($Step) {
# Activate the section and add the binds
.rightside.code tag configure step$Step -background white -relief flat
.rightside.code tag bind step$Step <Any-Enter> ".rightside.code tag configure step$Step -background #43ce80 -relief raised -borderwidth 1"
.rightside.code tag bind step$Step <Any-Leave> ".rightside.code tag configure step$Step -background {} -relief flat"
.rightside.code tag bind step$Step <1> "ExecuteExampleStep $Step"
} else {
# Deactivate the section and remove the binds
.rightside.code tag configure step$Step -background gray85 -relief flat
.rightside.code tag bind step$Step <Any-Enter> {}
.rightside.code tag bind step$Step <Any-Leave> {}
.rightside.code tag bind step$Step <1> {}
}
}
}
proc SelectExample {example} {
global RegTestDir ExampleScript LastExecutedExampleStep IsExecutable ExecutedSteps
wm title . "TEPAM Demo - $example"
catch {unset ExampleScript}
.rightside.code delete 0.0 end
# .rightside.code configure -background white
foreach tag [.rightside.code tag names] {
if {[regexp -- {^(step)|(title)\d$} $tag]} {
.rightside.code tag delete $tag
}
}
.rightside.code insert end "This demo uses the following styles and colors:" Introduction
.rightside.code insert end "\n - " Introduction "descriptions and comments" "Introduction Comment"
.rightside.code insert end "\n - " Introduction "program code ready to be executed" "Introduction Code"
.rightside.code insert end "\n - " Introduction "already executed, or not yet executable program code" "Introduction Code Executed"
.rightside.code insert end "\n - " Introduction "r: command return value" "Introduction Result_r"
.rightside.code insert end "\n - " Introduction "e: command return error" "Introduction Result_e"
.rightside.code insert end "\n - " Introduction "s: standard output print (stdout)" "Introduction Result_s"
.rightside.code insert end "\nClick now on each demo example section, one after " Introduction
.rightside.code insert end "the other. This will execute the program code of the " Introduction
.rightside.code insert end "section and insert the procedure results and standard and error " Introduction
.rightside.code insert end "outputs into the demo program listing.\n\n" Introduction
set f [open $RegTestDir/$example]
set Step -1
set Script ""
set ExampleStep ""
set LastExecutedExampleStep -1
set InitSteps {}
catch {array unset IsExecutable}
set ExecutedSteps {}
while {![eof $f]} {
if {[gets $f line]<0} break
if {[regexp {^\s*\#{4}\s*([^#]*)\s*\#{4}$} $line {} ExampleStep]} {
incr Step
set ExampleStep [string trim $ExampleStep]
.rightside.code insert end "#### $ExampleStep ####\n" "SectionTitle title$Step"
set ExampleScript($Step) {}
} elseif {[regexp {^\s*DemoControl\((\w+)\)\s+(.*)\s*} $line {} ControlType ControlExpr]} {
regexp {^\{\s*(.*)\s*\}$} $ControlExpr {} ControlExpr
switch $ControlType {
IsExecutable {set IsExecutable($Step) $ControlExpr}
Initialization {lappend InitSteps $Step}
}
} elseif {$ExampleStep!=""} {
if {[regexp {^\s*\#{8,100}$} $line]} {
set ExampleStep ""
continue
}
# regsub $LineStart $line {} line
regsub -all {\t} $line { } line
if {![regexp {^(.*?\{\s*#.*#\s*\}.*?)(#.*){0,1}$} $line {} ScriptLine ScriptComment]} {
regexp {^(.*?)(#.*){0,1}$} $line {} ScriptLine ScriptComment
}
.rightside.code insert end $ScriptLine "Code step$Step" "$ScriptComment\n" "step$Step Comment"
if {[string trim $ScriptLine]==""} continue
append Script "$ScriptLine\n"
if {[info complete $Script]} {
set Mark "step$Step-cmd[llength $ExampleScript($Step)]"
.rightside.code mark set $Mark "end - 1 lines"
.rightside.code mark gravity $Mark left
lappend ExampleScript($Step) [string trim $Script]
set Script ""
}
}
}
close $f
# Execute the initialization step if existing
foreach Step $InitSteps {
ExecuteExampleStep $Step
}
}
proc OpenConsole {} {
if {[catch {set ::tkcon::PRIV(root)}]} {
# Set PRIV(root) to an existing window to avoid a console creation
namespace eval ::tkcon {
set PRIV(root) .tkcon
set OPT(exec) ""
set OPT(slaveexit) "close"
}
# Search inside the *n.x environment for TkCon ('tkcon' and 'tkcon.tcl') ...
set TkConPath ""
catch {set TkConPath [exec which tkcon]}
if {$TkConPath==""} {catch {set TkConPath [exec which tkcon.tcl]}}
# Search inide the Windows environment for TkCon ...
catch {
package require registry
set TkConPath [registry get {HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\tclsh.exe} Path]/tkcon.tcl
regsub -all {\\} $TkConPath {/} TkConPat
}
if {$TkConPath!=""} {
# hide the standard console (only windows)
catch {console hide}
# Source tkcon. "Usually" this should also start the tkcon window.
set ::argv ""
uplevel #0 "source \{$TkConPath\}"
# TkCon versions have been observed that doesn't open the tkcon window during sourcing of tkcon. Initialize tkcon explicitly:
if {[lsearch [winfo children .] ".tkcon"]<0 && [lsearch [namespace children ::] "::tkcon"]} {
::tkcon::Init
}
tkcon show
} else {
if {$::tcl_platform(platform)=={windows}} {
console show
} else {
tk_messageBox -title "TkCon not found" -message "Cannot find tkcon.tcl." -type ok
}
}
} else {
if {[catch {wm deiconify $::tkcon::PRIV(root)}]} {
if {$::tcl_platform(platform)=={windows}} {
console show
} else {
tk_messageBox -title "Tk not available" -message "Cannot deiconify tkcon!" -type ok
}
}
}
}
set RegTestDir [file dirname [info script]]
menu .menu -bg $Config(MenuBG_Color) -fg $Config(MenuFG_Color) -tearoff 0
. configure -menu .menu
.menu add cascade -label File -menu .menu.file
menu .menu.file -bg $Config(MenuBG_Color) -fg $Config(MenuFG_Color) -tearoff 0
.menu.file add command -label "Show console" -command OpenConsole
.menu.file add command -label "Exit" -command exit_orig
pack [frame .leftside] -side left -fill y
pack [label .leftside.step1 -text "(1) Choose one of the demo \nexamples bellow.\n\n" -anchor w] -fill x
pack [label .leftside.label1 -text "Demo examples:" -anchor w] -fill x
set NbrExamples 0
foreach example [lsort -dictionary [glob $RegTestDir/*.demo]] {
set example [file tail $example]
pack [button .leftside.start$NbrExamples -command "SelectExample $example" -text $example -anchor w] -fill x
incr NbrExamples
}
pack [frame .rightside] -side left -expand yes -fill both
grid [label .rightside.step2 -text "(2) Execute the selected demo.\n\n" -anchor w] -row 0 -column 0 -sticky ew
grid [text .rightside.code -height 1 -wrap none -font {Courier 9} -background white -relief sunken -border 2 \
-yscrollcommand ".rightside.scrolly set" \
-xscrollcommand ".rightside.scrollx set" ] -row 1 -column 0 -sticky news -padx 2 -pady 2
.rightside.code tag configure Introduction -foreground blue -font {Courier 9} -wrap word
.rightside.code tag configure Comment -foreground blue -font {Courier 9}
.rightside.code tag configure Code -foreground black -font {Courier 9 bold}
.rightside.code tag configure SectionTitle -foreground black -background yellow -font {Courier 9 bold}
.rightside.code tag configure Result_r -foreground gold4 -background gray85 -font {Courier 9 italic}
.rightside.code tag configure Result_e -foreground red -background gray85 -font {Courier 9 italic}
.rightside.code tag configure Result_s -foreground green4 -background gray85 -font {Courier 9 italic}
.rightside.code tag configure Executed -background gray85
grid [scrollbar .rightside.scrolly -command ".rightside.code yview" -orient vertical] -row 1 -column 1 -sticky ns
grid [scrollbar .rightside.scrollx -command ".rightside.code xview" -orient horizontal] -row 2 -column 0 -sticky new
bind . <MouseWheel> "if {%D>0} {.rightside.code yview scroll -1 units} elseif {%D<0} {.rightside.code yview scroll 1 units}"
bind . <Button-4> ".rightside.code yview scroll -1 units"
bind . <Button-5> ".rightside.code yview scroll 1 units"
grid rowconfigure .rightside 1 -weight 70
grid columnconfigure .rightside 0 -weight 1
wm geometry . 900x800
wm title . "TEPAM Demo"
##########################################################################
# Id: tepam_demo.tcl
# Modifications:
#
# Revision 1.4 2013/10/14 droll
# * Improve the output/puts handling (procedure puts implemented by this file)
#
# Revision 1.4 2012/03/26 20:56:45 droll
# * TEPAM version 0.3.0
# * Replaces the control buttons by a menu.
# * Create an exit procedure to catch an eventual call of the exit command
# inside the console.
# * Adjust the colors and rewrite the explanations.
# * Display eventual errors with message boxes.
#
# Revision 1.3 2011/11/09 05:57:47 andreas_kupries
# * examples/tepam/tepam_demo.tcl [Bug 3425269]: Applied bug fixes
# for the demo script supplied by Stuart Cassoff.
#
# Revision 1.2 2011/01/21 16:00:49 droll
# * TEPAM version 0.2.0
#
# Revision 1.1 2010/02/11 21:54:38 droll
# * TEPAM module checkin
##########################################################################
|