Parent Directory | Revision Log
Rename for reorganization.
1 | /* $Header: /cvsroot/esrg/sfesrg/esrgpcpj/shared/tk_base/appinit.c,v 1.6 2002/04/23 06:26:42 dtashley Exp $ */ |
2 | |
3 | #define MODULE_APPINIT |
4 | |
5 | #include <tcl.h> |
6 | |
7 | #include "appinit.h" |
8 | #include "build_config.h" |
9 | #include "extninit.h" |
10 | #include "msgstrs.h" |
11 | |
12 | |
13 | #define INTERFACE 1 |
14 | #if INTERFACE |
15 | #define ET_TCLARGS ClientData clientData,Tcl_Interp*interp,int argc,char**argv |
16 | #define ET_OBJARGS ClientData clientData,Tcl_Interp*interp,int objc,Tcl_Obj*CONST objv[] |
17 | #endif |
18 | #define ET_ENABLE_OBJ 0 |
19 | #define ET_ENABLE_TK 1 |
20 | #define ET_AUTO_FORK 0 |
21 | #define ET_STANDALONE 0 |
22 | #define ET_N_BUILTIN_SCRIPT 31 |
23 | #define ET_VERSION "3.10" |
24 | #define ET_HAVE_APPINIT 0 |
25 | #define ET_HAVE_PREINIT 0 |
26 | #define ET_HAVE_MAIN 1 |
27 | #define ET_HAVE_CUSTOM_MAINLOOP 0 |
28 | #define ET_EXTENSION 0 |
29 | #define ET_SHROUD_KEY 0 |
30 | #define ET_READ_STDIN 0 |
31 | #define ET_CONSOLE 1 |
32 | static struct { |
33 | char *zName; |
34 | int (*xProc)(ET_TCLARGS); |
35 | } Et_CmdSet[] = { |
36 | {0, 0}}; |
37 | static char Et_zFile0[] = |
38 | "proc auto_reset {} {\n" |
39 | "global auto_execs auto_index auto_oldpath\n" |
40 | "foreach p [info procs] {\n" |
41 | "if {[info exists auto_index($p)] && ![string match auto_* $p]\n" |
42 | "&& ([lsearch -exact {unknown pkg_mkIndex tclPkgSetup\n" |
43 | "tcl_findLibrary pkg_compareExtension\n" |
44 | "tclMacPkgSearch tclPkgUnknown} $p] < 0)} {\n" |
45 | "rename $p {}\n" |
46 | "}\n" |
47 | "}\n" |
48 | "catch {unset auto_execs}\n" |
49 | "catch {unset auto_index}\n" |
50 | "catch {unset auto_oldpath}\n" |
51 | "}\n" |
52 | "proc tcl_findLibrary {basename version patch initScript enVarName varName} {\n" |
53 | "upvar #0 $varName the_library\n" |
54 | "global env errorInfo\n" |
55 | "set dirs {}\n" |
56 | "set errors {}\n" |
57 | "if {[info exist the_library] && [string compare $the_library {}]} {\n" |
58 | "lappend dirs $the_library\n" |
59 | "} else {\n" |
60 | "if {[info exists env($enVarName)]} {\n" |
61 | "lappend dirs $env($enVarName)\n" |
62 | "}\n" |
63 | "lappend dirs [file join [file dirname [info library]] \\\n" |
64 | "\011\011$basename$version]\n" |
65 | "set parentDir [file dirname [file dirname [info nameofexecutable]]]\n" |
66 | "set grandParentDir [file dirname $parentDir]\n" |
67 | "lappend dirs [file join $parentDir lib $basename$version]\n" |
68 | "lappend dirs [file join $grandParentDir lib $basename$version]\n" |
69 | "lappend dirs [file join $parentDir library]\n" |
70 | "lappend dirs [file join $grandParentDir library]\n" |
71 | "if {![regexp {.*[ab][0-9]*} $patch ver]} {\n" |
72 | "set ver $version\n" |
73 | "}\n" |
74 | "lappend dirs [file join $grandParentDir $basename$ver library]\n" |
75 | "lappend dirs [file join [file dirname $grandParentDir] $basename$ver library]\n" |
76 | "}\n" |
77 | "foreach i $dirs {\n" |
78 | "set the_library $i\n" |
79 | "set file [file join $i $initScript]\n" |
80 | "if {[interp issafe] || [file exists $file]} {\n" |
81 | "if {![catch {uplevel #0 [list source $file]} msg]} {\n" |
82 | "return\n" |
83 | "} else {\n" |
84 | "append errors \"$file: $msg\\n$errorInfo\\n\"\n" |
85 | "}\n" |
86 | "}\n" |
87 | "}\n" |
88 | "set msg \"Can't find a usable $initScript in the following directories: \\n\"\n" |
89 | "append msg \" $dirs\\n\\n\"\n" |
90 | "append msg \"$errors\\n\\n\"\n" |
91 | "append msg \"This probably means that $basename wasn't installed properly.\\n\"\n" |
92 | "error $msg\n" |
93 | "}\n" |
94 | "if {[interp issafe]} {\n" |
95 | "return\011;# Stop sourcing the file here\n" |
96 | "}\n" |
97 | "proc auto_mkindex {dir args} {\n" |
98 | "global errorCode errorInfo\n" |
99 | "if {[interp issafe]} {\n" |
100 | "error \"can't generate index within safe interpreter\"\n" |
101 | "}\n" |
102 | "set oldDir [pwd]\n" |
103 | "cd $dir\n" |
104 | "set dir [pwd]\n" |
105 | "append index \"# Tcl autoload index file, version 2.0\\n\"\n" |
106 | "append index \"# This file is generated by the \\\"auto_mkindex\\\" command\\n\"\n" |
107 | "append index \"# and sourced to set up indexing information for one or\\n\"\n" |
108 | "append index \"# more commands. Typically each line is a command that\\n\"\n" |
109 | "append index \"# sets an element in the auto_index array, where the\\n\"\n" |
110 | "append index \"# element name is the name of a command and the value is\\n\"\n" |
111 | "append index \"# a script that loads the command.\\n\\n\"\n" |
112 | "if {$args == \"\"} {\n" |
113 | "set args *.tcl\n" |
114 | "}\n" |
115 | "auto_mkindex_parser::init\n" |
116 | "foreach file [eval glob $args] {\n" |
117 | "if {[catch {auto_mkindex_parser::mkindex $file} msg] == 0} {\n" |
118 | "append index $msg\n" |
119 | "} else {\n" |
120 | "set code $errorCode\n" |
121 | "set info $errorInfo\n" |
122 | "cd $oldDir\n" |
123 | "error $msg $info $code\n" |
124 | "}\n" |
125 | "}\n" |
126 | "auto_mkindex_parser::cleanup\n" |
127 | "set fid [open \"tclIndex\" w]\n" |
128 | "puts -nonewline $fid $index\n" |
129 | "close $fid\n" |
130 | "cd $oldDir\n" |
131 | "}\n" |
132 | "proc auto_mkindex_old {dir args} {\n" |
133 | "global errorCode errorInfo\n" |
134 | "set oldDir [pwd]\n" |
135 | "cd $dir\n" |
136 | "set dir [pwd]\n" |
137 | "append index \"# Tcl autoload index file, version 2.0\\n\"\n" |
138 | "append index \"# This file is generated by the \\\"auto_mkindex\\\" command\\n\"\n" |
139 | "append index \"# and sourced to set up indexing information for one or\\n\"\n" |
140 | "append index \"# more commands. Typically each line is a command that\\n\"\n" |
141 | "append index \"# sets an element in the auto_index array, where the\\n\"\n" |
142 | "append index \"# element name is the name of a command and the value is\\n\"\n" |
143 | "append index \"# a script that loads the command.\\n\\n\"\n" |
144 | "if {[string equal $args \"\"]} {\n" |
145 | "set args *.tcl\n" |
146 | "}\n" |
147 | "foreach file [eval glob $args] {\n" |
148 | "set f \"\"\n" |
149 | "set error [catch {\n" |
150 | "set f [open $file]\n" |
151 | "while {[gets $f line] >= 0} {\n" |
152 | "if {[regexp {^proc[ \011]+([^ \011]*)} $line match procName]} {\n" |
153 | "set procName [lindex [auto_qualify $procName \"::\"] 0]\n" |
154 | "append index \"set [list auto_index($procName)]\"\n" |
155 | "append index \" \\[list source \\[file join \\$dir [list $file]\\]\\]\\n\"\n" |
156 | "}\n" |
157 | "}\n" |
158 | "close $f\n" |
159 | "} msg]\n" |
160 | "if {$error} {\n" |
161 | "set code $errorCode\n" |
162 | "set info $errorInfo\n" |
163 | "catch {close $f}\n" |
164 | "cd $oldDir\n" |
165 | "error $msg $info $code\n" |
166 | "}\n" |
167 | "}\n" |
168 | "set f \"\"\n" |
169 | "set error [catch {\n" |
170 | "set f [open tclIndex w]\n" |
171 | "puts -nonewline $f $index\n" |
172 | "close $f\n" |
173 | "cd $oldDir\n" |
174 | "} msg]\n" |
175 | "if {$error} {\n" |
176 | "set code $errorCode\n" |
177 | "set info $errorInfo\n" |
178 | "catch {close $f}\n" |
179 | "cd $oldDir\n" |
180 | "error $msg $info $code\n" |
181 | "}\n" |
182 | "}\n" |
183 | "namespace eval auto_mkindex_parser {\n" |
184 | "variable parser \"\" ;# parser used to build index\n" |
185 | "variable index \"\" ;# maintains index as it is built\n" |
186 | "variable scriptFile \"\" ;# name of file being processed\n" |
187 | "variable contextStack \"\" ;# stack of namespace scopes\n" |
188 | "variable imports \"\" ;# keeps track of all imported cmds\n" |
189 | "variable initCommands \"\" ;# list of commands that create aliases\n" |
190 | "proc init {} {\n" |
191 | "variable parser\n" |
192 | "variable initCommands\n" |
193 | "if {![interp issafe]} {\n" |
194 | "set parser [interp create -safe]\n" |
195 | "$parser hide info\n" |
196 | "$parser hide rename\n" |
197 | "$parser hide proc\n" |
198 | "$parser hide namespace\n" |
199 | "$parser hide eval\n" |
200 | "$parser hide puts\n" |
201 | "$parser invokehidden namespace delete ::\n" |
202 | "$parser invokehidden proc unknown {args} {}\n" |
203 | "$parser expose namespace\n" |
204 | "$parser invokehidden rename namespace _%@namespace\n" |
205 | "$parser expose eval\n" |
206 | "$parser invokehidden rename eval _%@eval\n" |
207 | "foreach cmd $initCommands {\n" |
208 | "eval $cmd\n" |
209 | "}\n" |
210 | "}\n" |
211 | "}\n" |
212 | "proc cleanup {} {\n" |
213 | "variable parser\n" |
214 | "interp delete $parser\n" |
215 | "unset parser\n" |
216 | "}\n" |
217 | "}\n" |
218 | "proc auto_mkindex_parser::mkindex {file} {\n" |
219 | "variable parser\n" |
220 | "variable index\n" |
221 | "variable scriptFile\n" |
222 | "variable contextStack\n" |
223 | "variable imports\n" |
224 | "set scriptFile $file\n" |
225 | "set fid [open $file]\n" |
226 | "set contents [read $fid]\n" |
227 | "close $fid\n" |
228 | "regsub -all {\\$} $contents \"\\0\" contents\n" |
229 | "set index \"\"\n" |
230 | "set contextStack \"\"\n" |
231 | "set imports \"\"\n" |
232 | "$parser eval $contents\n" |
233 | "foreach name $imports {\n" |
234 | "catch {$parser eval [list _%@namespace forget $name]}\n" |
235 | "}\n" |
236 | "return $index\n" |
237 | "}\n" |
238 | "proc auto_mkindex_parser::hook {cmd} {\n" |
239 | "variable initCommands\n" |
240 | "lappend initCommands $cmd\n" |
241 | "}\n" |
242 | "proc auto_mkindex_parser::slavehook {cmd} {\n" |
243 | "variable initCommands\n" |
244 | "lappend initCommands \"\\$parser eval [list $cmd]\"\n" |
245 | "}\n" |
246 | "proc auto_mkindex_parser::command {name arglist body} {\n" |
247 | "hook [list auto_mkindex_parser::commandInit $name $arglist $body]\n" |
248 | "}\n" |
249 | "proc auto_mkindex_parser::commandInit {name arglist body} {\n" |
250 | "variable parser\n" |
251 | "set ns [namespace qualifiers $name]\n" |
252 | "set tail [namespace tail $name]\n" |
253 | "if {[string equal $ns \"\"]} {\n" |
254 | "set fakeName \"[namespace current]::_%@fake_$tail\"\n" |
255 | "} else {\n" |
256 | "set fakeName \"_%@fake_$name\"\n" |
257 | "regsub -all {::} $fakeName \"_\" fakeName\n" |
258 | "set fakeName \"[namespace current]::$fakeName\"\n" |
259 | "}\n" |
260 | "proc $fakeName $arglist $body\n" |
261 | "if {[regexp {::} $name]} {\n" |
262 | "set exportCmd [list _%@namespace export [namespace tail $name]]\n" |
263 | "$parser eval [list _%@namespace eval $ns $exportCmd]\n" |
264 | "set alias [namespace tail $fakeName]\n" |
265 | "$parser invokehidden proc $name {args} \"_%@eval {$alias} \\$args\"\n" |
266 | "$parser alias $alias $fakeName\n" |
267 | "} else {\n" |
268 | "$parser alias $name $fakeName\n" |
269 | "}\n" |
270 | "return\n" |
271 | "}\n" |
272 | "proc auto_mkindex_parser::fullname {name} {\n" |
273 | "variable contextStack\n" |
274 | "if {![string match ::* $name]} {\n" |
275 | "foreach ns $contextStack {\n" |
276 | "set name \"${ns}::$name\"\n" |
277 | "if {[string match ::* $name]} {\n" |
278 | "break\n" |
279 | "}\n" |
280 | "}\n" |
281 | "}\n" |
282 | "if {[string equal [namespace qualifiers $name] \"\"]} {\n" |
283 | "set name [namespace tail $name]\n" |
284 | "} elseif {![string match ::* $name]} {\n" |
285 | "set name \"::$name\"\n" |
286 | "}\n" |
287 | "regsub -all \"\\0\" $name \"\\$\" name\n" |
288 | "return $name\n" |
289 | "}\n" |
290 | "auto_mkindex_parser::command proc {name args} {\n" |
291 | "variable index\n" |
292 | "variable scriptFile\n" |
293 | "append index [list set auto_index([fullname $name])] \\\n" |
294 | "\011 [format { [list source [file join $dir %s]]} \\\n" |
295 | "\011 [file split $scriptFile]] \"\\n\"\n" |
296 | "}\n" |
297 | "auto_mkindex_parser::hook {\n" |
298 | "if {![catch {package require tbcload}]} {\n" |
299 | "if {[llength [info commands tbcload::bcproc]] == 0} {\n" |
300 | "auto_load tbcload::bcproc\n" |
301 | "}\n" |
302 | "load {} tbcload $auto_mkindex_parser::parser\n" |
303 | "auto_mkindex_parser::commandInit tbcload::bcproc {name args} {\n" |
304 | "variable index\n" |
305 | "variable scriptFile\n" |
306 | "append index [list set auto_index([fullname $name])] \\\n" |
307 | "\011\011 [format { [list source [file join $dir %s]]} \\\n" |
308 | "\011\011 [file split $scriptFile]] \"\\n\"\n" |
309 | "}\n" |
310 | "}\n" |
311 | "}\n" |
312 | "auto_mkindex_parser::command namespace {op args} {\n" |
313 | "switch -- $op {\n" |
314 | "eval {\n" |
315 | "variable parser\n" |
316 | "variable contextStack\n" |
317 | "set name [lindex $args 0]\n" |
318 | "set args [lrange $args 1 end]\n" |
319 | "set contextStack [linsert $contextStack 0 $name]\n" |
320 | "$parser eval [list _%@namespace eval $name] $args\n" |
321 | "set contextStack [lrange $contextStack 1 end]\n" |
322 | "}\n" |
323 | "import {\n" |
324 | "variable parser\n" |
325 | "variable imports\n" |
326 | "foreach pattern $args {\n" |
327 | "if {[string compare $pattern \"-force\"]} {\n" |
328 | "lappend imports $pattern\n" |
329 | "}\n" |
330 | "}\n" |
331 | "catch {$parser eval \"_%@namespace import $args\"}\n" |
332 | "}\n" |
333 | "}\n" |
334 | "}\n" |
335 | "return\n" |
336 | ; |
337 | static char Et_zFile1[] = |
338 | "namespace eval tcl {\n" |
339 | "variable history\n" |
340 | "if {![info exists history]} {\n" |
341 | "array set history {\n" |
342 | "nextid\0110\n" |
343 | "keep\01120\n" |
344 | "oldest\011-20\n" |
345 | "}\n" |
346 | "}\n" |
347 | "}\n" |
348 | "proc history {args} {\n" |
349 | "set len [llength $args]\n" |
350 | "if {$len == 0} {\n" |
351 | "return [tcl::HistInfo]\n" |
352 | "}\n" |
353 | "set key [lindex $args 0]\n" |
354 | "set options \"add, change, clear, event, info, keep, nextid, or redo\"\n" |
355 | "switch -glob -- $key {\n" |
356 | "a* { # history add\n" |
357 | "if {$len > 3} {\n" |
358 | "return -code error \"wrong # args: should be \\\"history add event ?exec?\\\"\"\n" |
359 | "}\n" |
360 | "if {![string match $key* add]} {\n" |
361 | "return -code error \"bad option \\\"$key\\\": must be $options\"\n" |
362 | "}\n" |
363 | "if {$len == 3} {\n" |
364 | "set arg [lindex $args 2]\n" |
365 | "if {! ([string match e* $arg] && [string match $arg* exec])} {\n" |
366 | "return -code error \"bad argument \\\"$arg\\\": should be \\\"exec\\\"\"\n" |
367 | "}\n" |
368 | "}\n" |
369 | "return [tcl::HistAdd [lindex $args 1] [lindex $args 2]]\n" |
370 | "}\n" |
371 | "ch* { # history change\n" |
372 | "if {($len > 3) || ($len < 2)} {\n" |
373 | "return -code error \"wrong # args: should be \\\"history change newValue ?event?\\\"\"\n" |
374 | "}\n" |
375 | "if {![string match $key* change]} {\n" |
376 | "return -code error \"bad option \\\"$key\\\": must be $options\"\n" |
377 | "}\n" |
378 | "if {$len == 2} {\n" |
379 | "set event 0\n" |
380 | "} else {\n" |
381 | "set event [lindex $args 2]\n" |
382 | "}\n" |
383 | "return [tcl::HistChange [lindex $args 1] $event]\n" |
384 | "}\n" |
385 | "cl* { # history clear\n" |
386 | "if {($len > 1)} {\n" |
387 | "return -code error \"wrong # args: should be \\\"history clear\\\"\"\n" |
388 | "}\n" |
389 | "if {![string match $key* clear]} {\n" |
390 | "return -code error \"bad option \\\"$key\\\": must be $options\"\n" |
391 | "}\n" |
392 | "return [tcl::HistClear]\n" |
393 | "}\n" |
394 | "e* { # history event\n" |
395 | "if {$len > 2} {\n" |
396 | "return -code error \"wrong # args: should be \\\"history event ?event?\\\"\"\n" |
397 | "}\n" |
398 | "if {![string match $key* event]} {\n" |
399 | "return -code error \"bad option \\\"$key\\\": must be $options\"\n" |
400 | "}\n" |
401 | "if {$len == 1} {\n" |
402 | "set event -1\n" |
403 | "} else {\n" |
404 | "set event [lindex $args 1]\n" |
405 | "}\n" |
406 | "return [tcl::HistEvent $event]\n" |
407 | "}\n" |
408 | "i* { # history info\n" |
409 | "if {$len > 2} {\n" |
410 | "return -code error \"wrong # args: should be \\\"history info ?count?\\\"\"\n" |
411 | "}\n" |
412 | "if {![string match $key* info]} {\n" |
413 | "return -code error \"bad option \\\"$key\\\": must be $options\"\n" |
414 | "}\n" |
415 | "return [tcl::HistInfo [lindex $args 1]]\n" |
416 | "}\n" |
417 | "k* { # history keep\n" |
418 | "if {$len > 2} {\n" |
419 | "return -code error \"wrong # args: should be \\\"history keep ?count?\\\"\"\n" |
420 | "}\n" |
421 | "if {$len == 1} {\n" |
422 | "return [tcl::HistKeep]\n" |
423 | "} else {\n" |
424 | "set limit [lindex $args 1]\n" |
425 | "if {[catch {expr {~$limit}}] || ($limit < 0)} {\n" |
426 | "return -code error \"illegal keep count \\\"$limit\\\"\"\n" |
427 | "}\n" |
428 | "return [tcl::HistKeep $limit]\n" |
429 | "}\n" |
430 | "}\n" |
431 | "n* { # history nextid\n" |
432 | "if {$len > 1} {\n" |
433 | "return -code error \"wrong # args: should be \\\"history nextid\\\"\"\n" |
434 | "}\n" |
435 | "if {![string match $key* nextid]} {\n" |
436 | "return -code error \"bad option \\\"$key\\\": must be $options\"\n" |
437 | "}\n" |
438 | "return [expr {$tcl::history(nextid) + 1}]\n" |
439 | "}\n" |
440 | "r* { # history redo\n" |
441 | "if {$len > 2} {\n" |
442 | "return -code error \"wrong # args: should be \\\"history redo ?event?\\\"\"\n" |
443 | "}\n" |
444 | "if {![string match $key* redo]} {\n" |
445 | "return -code error \"bad option \\\"$key\\\": must be $options\"\n" |
446 | "}\n" |
447 | "return [tcl::HistRedo [lindex $args 1]]\n" |
448 | "}\n" |
449 | "default {\n" |
450 | "return -code error \"bad option \\\"$key\\\": must be $options\"\n" |
451 | "}\n" |
452 | "}\n" |
453 | "}\n" |
454 | "proc tcl::HistAdd {command {exec {}}} {\n" |
455 | "variable history\n" |
456 | "set i [incr history(nextid)]\n" |
457 | "set history($i) $command\n" |
458 | "set j [incr history(oldest)]\n" |
459 | "if {[info exists history($j)]} {unset history($j)}\n" |
460 | "if {[string match e* $exec]} {\n" |
461 | "return [uplevel #0 $command]\n" |
462 | "} else {\n" |
463 | "return {}\n" |
464 | "}\n" |
465 | "}\n" |
466 | "proc tcl::HistKeep {{limit {}}} {\n" |
467 | "variable history\n" |
468 | "if {[string length $limit] == 0} {\n" |
469 | "return $history(keep)\n" |
470 | "} else {\n" |
471 | "set oldold $history(oldest)\n" |
472 | "set history(oldest) [expr {$history(nextid) - $limit}]\n" |
473 | "for {} {$oldold <= $history(oldest)} {incr oldold} {\n" |
474 | "if {[info exists history($oldold)]} {unset history($oldold)}\n" |
475 | "}\n" |
476 | "set history(keep) $limit\n" |
477 | "}\n" |
478 | "}\n" |
479 | "proc tcl::HistClear {} {\n" |
480 | "variable history\n" |
481 | "set keep $history(keep)\n" |
482 | "unset history\n" |
483 | "array set history [list \\\n" |
484 | "\011nextid\0110\011\\\n" |
485 | "\011keep\011$keep\011\\\n" |
486 | "\011oldest\011-$keep\011\\\n" |
487 | " ]\n" |
488 | "}\n" |
489 | "proc tcl::HistInfo {{num {}}} {\n" |
490 | "variable history\n" |
491 | "if {$num == {}} {\n" |
492 | "set num [expr {$history(keep) + 1}]\n" |
493 | "}\n" |
494 | "set result {}\n" |
495 | "set newline \"\"\n" |
496 | "for {set i [expr {$history(nextid) - $num + 1}]} \\\n" |
497 | "\011 {$i <= $history(nextid)} {incr i} {\n" |
498 | "if {![info exists history($i)]} {\n" |
499 | "continue\n" |
500 | "}\n" |
501 | "set cmd [string trimright $history($i) \\ \\n]\n" |
502 | "regsub -all \\n $cmd \"\\n\\t\" cmd\n" |
503 | "append result $newline[format \"%6d %s\" $i $cmd]\n" |
504 | "set newline \\n\n" |
505 | "}\n" |
506 | "return $result\n" |
507 | "}\n" |
508 | "proc tcl::HistRedo {{event -1}} {\n" |
509 | "variable history\n" |
510 | "if {[string length $event] == 0} {\n" |
511 | "set event -1\n" |
512 | "}\n" |
513 | "set i [HistIndex $event]\n" |
514 | "if {$i == $history(nextid)} {\n" |
515 | "return -code error \"cannot redo the current event\"\n" |
516 | "}\n" |
517 | "set cmd $history($i)\n" |
518 | "HistChange $cmd 0\n" |
519 | "uplevel #0 $cmd\n" |
520 | "}\n" |
521 | "proc tcl::HistIndex {event} {\n" |
522 | "variable history\n" |
523 | "if {[catch {expr {~$event}}]} {\n" |
524 | "for {set i $history(nextid)} {[info exists history($i)]} {incr i -1} {\n" |
525 | "if {[string match $event* $history($i)]} {\n" |
526 | "return $i;\n" |
527 | "}\n" |
528 | "if {[string match $event $history($i)]} {\n" |
529 | "return $i;\n" |
530 | "}\n" |
531 | "}\n" |
532 | "return -code error \"no event matches \\\"$event\\\"\"\n" |
533 | "} elseif {$event <= 0} {\n" |
534 | "set i [expr {$history(nextid) + $event}]\n" |
535 | "} else {\n" |
536 | "set i $event\n" |
537 | "}\n" |
538 | "if {$i <= $history(oldest)} {\n" |
539 | "return -code error \"event \\\"$event\\\" is too far in the past\"\n" |
540 | "}\n" |
541 | "if {$i > $history(nextid)} {\n" |
542 | "return -code error \"event \\\"$event\\\" hasn't occured yet\"\n" |
543 | "}\n" |
544 | "return $i\n" |
545 | "}\n" |
546 | "proc tcl::HistEvent {event} {\n" |
547 | "variable history\n" |
548 | "set i [HistIndex $event]\n" |
549 | "if {[info exists history($i)]} {\n" |
550 | "return [string trimright $history($i) \\ \\n]\n" |
551 | "} else {\n" |
552 | "return \"\";\n" |
553 | "}\n" |
554 | "}\n" |
555 | "proc tcl::HistChange {cmd {event 0}} {\n" |
556 | "variable history\n" |
557 | "set i [HistIndex $event]\n" |
558 | "set history($i) $cmd\n" |
559 | "}\n" |
560 | ; |
561 | static char Et_zFile2[] = |
562 | "if {[info commands package] == \"\"} {\n" |
563 | "error \"version mismatch: library\\nscripts expect Tcl version 7.5b1 or later but the loaded version is\\nonly [info patchlevel]\"\n" |
564 | "}\n" |
565 | "package require -exact Tcl 8.3\n" |
566 | "if {![info exists auto_path]} {\n" |
567 | "if {[info exist env(TCLLIBPATH)]} {\n" |
568 | "set auto_path $env(TCLLIBPATH)\n" |
569 | "} else {\n" |
570 | "set auto_path \"\"\n" |
571 | "}\n" |
572 | "}\n" |
573 | "if {[string compare [info library] {}]} {\n" |
574 | "foreach __dir [list [info library] [file dirname [info library]]] {\n" |
575 | "if {[lsearch -exact $auto_path $__dir] < 0} {\n" |
576 | "lappend auto_path $__dir\n" |
577 | "}\n" |
578 | "}\n" |
579 | "}\n" |
580 | "set __dir [file join [file dirname [file dirname \\\n" |
581 | "\011[info nameofexecutable]]] lib]\n" |
582 | "if {[lsearch -exact $auto_path $__dir] < 0} {\n" |
583 | "lappend auto_path $__dir\n" |
584 | "}\n" |
585 | "if {[info exist tcl_pkgPath]} {\n" |
586 | "foreach __dir $tcl_pkgPath {\n" |
587 | "if {[lsearch -exact $auto_path $__dir] < 0} {\n" |
588 | "lappend auto_path $__dir\n" |
589 | "}\n" |
590 | "}\n" |
591 | "}\n" |
592 | "if {[info exists __dir]} {\n" |
593 | "unset __dir\n" |
594 | "}\n" |
595 | "if {(![interp issafe]) && [string equal $tcl_platform(platform) \"windows\"]} {\n" |
596 | "namespace eval tcl {\n" |
597 | "proc envTraceProc {lo n1 n2 op} {\n" |
598 | "set x $::env($n2)\n" |
599 | "set ::env($lo) $x\n" |
600 | "set ::env([string toupper $lo]) $x\n" |
601 | "}\n" |
602 | "}\n" |
603 | "foreach p [array names env] {\n" |
604 | "set u [string toupper $p]\n" |
605 | "if {[string compare $u $p]} {\n" |
606 | "switch -- $u {\n" |
607 | "COMSPEC -\n" |
608 | "PATH {\n" |
609 | "if {![info exists env($u)]} {\n" |
610 | "set env($u) $env($p)\n" |
611 | "}\n" |
612 | "trace variable env($p) w [list tcl::envTraceProc $p]\n" |
613 | "trace variable env($u) w [list tcl::envTraceProc $p]\n" |
614 | "}\n" |
615 | "}\n" |
616 | "}\n" |
617 | "}\n" |
618 | "if {[info exists p]} {\n" |
619 | "unset p\n" |
620 | "}\n" |
621 | "if {[info exists u]} {\n" |
622 | "unset u\n" |
623 | "}\n" |
624 | "if {![info exists env(COMSPEC)]} {\n" |
625 | "if {[string equal $tcl_platform(os) \"Windows NT\"]} {\n" |
626 | "set env(COMSPEC) cmd.exe\n" |
627 | "} else {\n" |
628 | "set env(COMSPEC) command.com\n" |
629 | "}\n" |
630 | "}\n" |
631 | "}\n" |
632 | "package unknown tclPkgUnknown\n" |
633 | "if {[llength [info commands exec]] == 0} {\n" |
634 | "set auto_noexec 1\n" |
635 | "}\n" |
636 | "set errorCode \"\"\n" |
637 | "set errorInfo \"\"\n" |
638 | "if {[llength [info commands tclLog]] == 0} {\n" |
639 | "proc tclLog {string} {\n" |
640 | "catch {puts stderr $string}\n" |
641 | "}\n" |
642 | "}\n" |
643 | "proc unknown args {\n" |
644 | "global auto_noexec auto_noload env unknown_pending tcl_interactive\n" |
645 | "global errorCode errorInfo\n" |
646 | "set cmd [lindex $args 0]\n" |
647 | "if {[regexp \"^namespace\\[ \\t\\n\\]+inscope\" $cmd] && [llength $cmd] == 4} {\n" |
648 | "set arglist [lrange $args 1 end]\n" |
649 | "set ret [catch {uplevel $cmd $arglist} result]\n" |
650 | "if {$ret == 0} {\n" |
651 | "return $result\n" |
652 | "} else {\n" |
653 | "return -code $ret -errorcode $errorCode $result\n" |
654 | "}\n" |
655 | "}\n" |
656 | "set savedErrorCode $errorCode\n" |
657 | "set savedErrorInfo $errorInfo\n" |
658 | "set name [lindex $args 0]\n" |
659 | "if {![info exists auto_noload]} {\n" |
660 | "if {[info exists unknown_pending($name)]} {\n" |
661 | "return -code error \"self-referential recursion in \\\"unknown\\\" for command \\\"$name\\\"\";\n" |
662 | "}\n" |
663 | "set unknown_pending($name) pending;\n" |
664 | "set ret [catch {auto_load $name [uplevel 1 {namespace current}]} msg]\n" |
665 | "unset unknown_pending($name);\n" |
666 | "if {$ret != 0} {\n" |
667 | "append errorInfo \"\\n (autoloading \\\"$name\\\")\"\n" |
668 | "return -code $ret -errorcode $errorCode -errorinfo $errorInfo $msg\n" |
669 | "}\n" |
670 | "if {![array size unknown_pending]} {\n" |
671 | "unset unknown_pending\n" |
672 | "}\n" |
673 | "if {$msg} {\n" |
674 | "set errorCode $savedErrorCode\n" |
675 | "set errorInfo $savedErrorInfo\n" |
676 | "set code [catch {uplevel 1 $args} msg]\n" |
677 | "if {$code == 1} {\n" |
678 | "set new [split $errorInfo \\n]\n" |
679 | "set new [join [lrange $new 0 [expr {[llength $new] - 6}]] \\n]\n" |
680 | "return -code error -errorcode $errorCode \\\n" |
681 | "\011\011\011-errorinfo $new $msg\n" |
682 | "} else {\n" |
683 | "return -code $code $msg\n" |
684 | "}\n" |
685 | "}\n" |
686 | "}\n" |
687 | "if {([info level] == 1) && [string equal [info script] \"\"] \\\n" |
688 | "\011 && [info exists tcl_interactive] && $tcl_interactive} {\n" |
689 | "if {![info exists auto_noexec]} {\n" |
690 | "set new [auto_execok $name]\n" |
691 | "if {[string compare {} $new]} {\n" |
692 | "set errorCode $savedErrorCode\n" |
693 | "set errorInfo $savedErrorInfo\n" |
694 | "set redir \"\"\n" |
695 | "if {[string equal [info commands console] \"\"]} {\n" |
696 | "set redir \">&@stdout <@stdin\"\n" |
697 | "}\n" |
698 | "return [uplevel exec $redir $new [lrange $args 1 end]]\n" |
699 | "}\n" |
700 | "}\n" |
701 | "set errorCode $savedErrorCode\n" |
702 | "set errorInfo $savedErrorInfo\n" |
703 | "if {[string equal $name \"!!\"]} {\n" |
704 | "set newcmd [history event]\n" |
705 | "} elseif {[regexp {^!(.+)$} $name dummy event]} {\n" |
706 | "set newcmd [history event $event]\n" |
707 | "} elseif {[regexp {^\\^([^^]*)\\^([^^]*)\\^?$} $name dummy old new]} {\n" |
708 | "set newcmd [history event -1]\n" |
709 | "catch {regsub -all -- $old $newcmd $new newcmd}\n" |
710 | "}\n" |
711 | "if {[info exists newcmd]} {\n" |
712 | "tclLog $newcmd\n" |
713 | "history change $newcmd 0\n" |
714 | "return [uplevel $newcmd]\n" |
715 | "}\n" |
716 | "set ret [catch {set cmds [info commands $name*]} msg]\n" |
717 | "if {[string equal $name \"::\"]} {\n" |
718 | "set name \"\"\n" |
719 | "}\n" |
720 | "if {$ret != 0} {\n" |
721 | "return -code $ret -errorcode $errorCode \\\n" |
722 | "\011\011\"error in unknown while checking if \\\"$name\\\" is a unique command abbreviation: $msg\"\n" |
723 | "}\n" |
724 | "if {[llength $cmds] == 1} {\n" |
725 | "return [uplevel [lreplace $args 0 0 $cmds]]\n" |
726 | "}\n" |
727 | "if {[llength $cmds]} {\n" |
728 | "if {[string equal $name \"\"]} {\n" |
729 | "return -code error \"empty command name \\\"\\\"\"\n" |
730 | "} else {\n" |
731 | "return -code error \\\n" |
732 | "\011\011\011\"ambiguous command name \\\"$name\\\": [lsort $cmds]\"\n" |
733 | "}\n" |
734 | "}\n" |
735 | "}\n" |
736 | "return -code error \"invalid command name \\\"$name\\\"\"\n" |
737 | "}\n" |
738 | "proc auto_load {cmd {namespace {}}} {\n" |
739 | "global auto_index auto_oldpath auto_path\n" |
740 | "if {[string length $namespace] == 0} {\n" |
741 | "set namespace [uplevel {namespace current}]\n" |
742 | "}\n" |
743 | "set nameList [auto_qualify $cmd $namespace]\n" |
744 | "lappend nameList $cmd\n" |
745 | "foreach name $nameList {\n" |
746 | "if {[info exists auto_index($name)]} {\n" |
747 | "uplevel #0 $auto_index($name)\n" |
748 | "return [expr {[info commands $name] != \"\"}]\n" |
749 | "}\n" |
750 | "}\n" |
751 | "if {![info exists auto_path]} {\n" |
752 | "return 0\n" |
753 | "}\n" |
754 | "if {![auto_load_index]} {\n" |
755 | "return 0\n" |
756 | "}\n" |
757 | "foreach name $nameList {\n" |
758 | "if {[info exists auto_index($name)]} {\n" |
759 | "uplevel #0 $auto_index($name)\n" |
760 | "if { ![string equal [namespace which -command $name] \"\"] } {\n" |
761 | "return 1\n" |
762 | "}\n" |
763 | "}\n" |
764 | "}\n" |
765 | "return 0\n" |
766 | "}\n" |
767 | "proc auto_load_index {} {\n" |
768 | "global auto_index auto_oldpath auto_path errorInfo errorCode\n" |
769 | "if {[info exists auto_oldpath] && \\\n" |
770 | "\011 [string equal $auto_oldpath $auto_path]} {\n" |
771 | "return 0\n" |
772 | "}\n" |
773 | "set auto_oldpath $auto_path\n" |
774 | "set issafe [interp issafe]\n" |
775 | "for {set i [expr {[llength $auto_path] - 1}]} {$i >= 0} {incr i -1} {\n" |
776 | "set dir [lindex $auto_path $i]\n" |
777 | "set f \"\"\n" |
778 | "if {$issafe} {\n" |
779 | "catch {source [file join $dir tclIndex]}\n" |
780 | "} elseif {[catch {set f [open [file join $dir tclIndex]]}]} {\n" |
781 | "continue\n" |
782 | "} else {\n" |
783 | "set error [catch {\n" |
784 | "set id [gets $f]\n" |
785 | "if {[string equal $id \\\n" |
786 | "\011\011\011\"# Tcl autoload index file, version 2.0\"]} {\n" |
787 | "eval [read $f]\n" |
788 | "} elseif {[string equal $id \"# Tcl autoload index file: each line identifies a Tcl\"]} {\n" |
789 | "while {[gets $f line] >= 0} {\n" |
790 | "if {[string equal [string index $line 0] \"#\"] \\\n" |
791 | "\011\011\011\011|| ([llength $line] != 2)} {\n" |
792 | "continue\n" |
793 | "}\n" |
794 | "set name [lindex $line 0]\n" |
795 | "set auto_index($name) \\\n" |
796 | "\011\011\011\011\"source [file join $dir [lindex $line 1]]\"\n" |
797 | "}\n" |
798 | "} else {\n" |
799 | "error \"[file join $dir tclIndex] isn't a proper Tcl index file\"\n" |
800 | "}\n" |
801 | "} msg]\n" |
802 | "if {[string compare $f \"\"]} {\n" |
803 | "close $f\n" |
804 | "}\n" |
805 | "if {$error} {\n" |
806 | "error $msg $errorInfo $errorCode\n" |
807 | "}\n" |
808 | "}\n" |
809 | "}\n" |
810 | "return 1\n" |
811 | "}\n" |
812 | "proc auto_qualify {cmd namespace} {\n" |
813 | "set n [regsub -all {::+} $cmd :: cmd]\n" |
814 | "if {[regexp {^::(.*)$} $cmd x tail]} {\n" |
815 | "if {$n > 1} {\n" |
816 | "return [list $cmd]\n" |
817 | "} else {\n" |
818 | "return [list $tail]\n" |
819 | "}\n" |
820 | "}\n" |
821 | "if {$n == 0} {\n" |
822 | "if {[string equal $namespace ::]} {\n" |
823 | "return [list $cmd]\n" |
824 | "} else {\n" |
825 | "return [list ${namespace}::$cmd $cmd]\n" |
826 | "}\n" |
827 | "} elseif {[string equal $namespace ::]} {\n" |
828 | "return [list ::$cmd]\n" |
829 | "} else {\n" |
830 | "return [list ${namespace}::$cmd ::$cmd]\n" |
831 | "}\n" |
832 | "}\n" |
833 | "proc auto_import {pattern} {\n" |
834 | "global auto_index\n" |
835 | "set ns [uplevel namespace current]\n" |
836 | "set patternList [auto_qualify $pattern $ns]\n" |
837 | "auto_load_index\n" |
838 | "foreach pattern $patternList {\n" |
839 | "foreach name [array names auto_index] {\n" |
840 | "if {[string match $pattern $name] && \\\n" |
841 | "\011\011 [string equal \"\" [info commands $name]]} {\n" |
842 | "uplevel #0 $auto_index($name)\n" |
843 | "}\n" |
844 | "}\n" |
845 | "}\n" |
846 | "}\n" |
847 | "if {[string equal windows $tcl_platform(platform)]} {\n" |
848 | "proc auto_execok name {\n" |
849 | "global auto_execs env tcl_platform\n" |
850 | "if {[info exists auto_execs($name)]} {\n" |
851 | "return $auto_execs($name)\n" |
852 | "}\n" |
853 | "set auto_execs($name) \"\"\n" |
854 | "set shellBuiltins [list cls copy date del erase dir echo mkdir \\\n" |
855 | "\011 md rename ren rmdir rd time type ver vol]\n" |
856 | "if {[string equal $tcl_platform(os) \"Windows NT\"]} {\n" |
857 | "lappend shellBuiltins \"start\"\n" |
858 | "}\n" |
859 | "if {[lsearch -exact $shellBuiltins $name] != -1} {\n" |
860 | "return [set auto_execs($name) [list $env(COMSPEC) /c $name]]\n" |
861 | "}\n" |
862 | "if {[llength [file split $name]] != 1} {\n" |
863 | "foreach ext {{} .com .exe .bat} {\n" |
864 | "set file ${name}${ext}\n" |
865 | "if {[file exists $file] && ![file isdirectory $file]} {\n" |
866 | "return [set auto_execs($name) [list $file]]\n" |
867 | "}\n" |
868 | "}\n" |
869 | "return \"\"\n" |
870 | "}\n" |
871 | "set path \"[file dirname [info nameof]];.;\"\n" |
872 | "if {[info exists env(WINDIR)]} {\n" |
873 | "set windir $env(WINDIR) \n" |
874 | "}\n" |
875 | "if {[info exists windir]} {\n" |
876 | "if {[string equal $tcl_platform(os) \"Windows NT\"]} {\n" |
877 | "append path \"$windir/system32;\"\n" |
878 | "}\n" |
879 | "append path \"$windir/system;$windir;\"\n" |
880 | "}\n" |
881 | "foreach var {PATH Path path} {\n" |
882 | "if {[info exists env($var)]} {\n" |
883 | "append path \";$env($var)\"\n" |
884 | "}\n" |
885 | "}\n" |
886 | "foreach dir [split $path {;}] {\n" |
887 | "if {[info exists checked($dir)] || [string equal {} $dir]} { continue }\n" |
888 | "set checked($dir) {}\n" |
889 | "foreach ext {{} .com .exe .bat} {\n" |
890 | "set file [file join $dir ${name}${ext}]\n" |
891 | "if {[file exists $file] && ![file isdirectory $file]} {\n" |
892 | "return [set auto_execs($name) [list $file]]\n" |
893 | "}\n" |
894 | "}\n" |
895 | "}\n" |
896 | "return \"\"\n" |
897 | "}\n" |
898 | "} else {\n" |
899 | "proc auto_execok name {\n" |
900 | "global auto_execs env\n" |
901 | "if {[info exists auto_execs($name)]} {\n" |
902 | "return $auto_execs($name)\n" |
903 | "}\n" |
904 | "set auto_execs($name) \"\"\n" |
905 | "if {[llength [file split $name]] != 1} {\n" |
906 | "if {[file executable $name] && ![file isdirectory $name]} {\n" |
907 | "set auto_execs($name) [list $name]\n" |
908 | "}\n" |
909 | "return $auto_execs($name)\n" |
910 | "}\n" |
911 | "foreach dir [split $env(PATH) :] {\n" |
912 | "if {[string equal $dir \"\"]} {\n" |
913 | "set dir .\n" |
914 | "}\n" |
915 | "set file [file join $dir $name]\n" |
916 | "if {[file executable $file] && ![file isdirectory $file]} {\n" |
917 | "set auto_execs($name) [list $file]\n" |
918 | "return $auto_execs($name)\n" |
919 | "}\n" |
920 | "}\n" |
921 | "return \"\"\n" |
922 | "}\n" |
923 | "}\n" |
924 | ; |
925 | static char Et_zFile3[] = |
926 | "namespace eval ::pkg {\n" |
927 | "}\n" |
928 | "proc pkg_compareExtension { fileName {ext {}} } {\n" |
929 | "global tcl_platform\n" |
930 | "if {[string length $ext] == 0} {\n" |
931 | "set ext [info sharedlibextension]\n" |
932 | "}\n" |
933 | "if {[string equal $tcl_platform(platform) \"windows\"]} {\n" |
934 | "return [string equal -nocase [file extension $fileName] $ext]\n" |
935 | "} else {\n" |
936 | "return [string equal [file extension $fileName] $ext]\n" |
937 | "}\n" |
938 | "}\n" |
939 | "proc pkg_mkIndex {args} {\n" |
940 | "global errorCode errorInfo\n" |
941 | "set usage {\"pkg_mkIndex ?-direct? ?-verbose? ?-load pattern? ?--? dir ?pattern ...?\"};\n" |
942 | "set argCount [llength $args]\n" |
943 | "if {$argCount < 1} {\n" |
944 | "return -code error \"wrong # args: should be\\n$usage\"\n" |
945 | "}\n" |
946 | "set more \"\"\n" |
947 | "set direct 1\n" |
948 | "set doVerbose 0\n" |
949 | "set loadPat \"\"\n" |
950 | "for {set idx 0} {$idx < $argCount} {incr idx} {\n" |
951 | "set flag [lindex $args $idx]\n" |
952 | "switch -glob -- $flag {\n" |
953 | "-- {\n" |
954 | "incr idx\n" |
955 | "break\n" |
956 | "}\n" |
957 | "-verbose {\n" |
958 | "set doVerbose 1\n" |
959 | "}\n" |
960 | "-lazy {\n" |
961 | "set direct 0\n" |
962 | "append more \" -lazy\"\n" |
963 | "}\n" |
964 | "-direct {\n" |
965 | "append more \" -direct\"\n" |
966 | "}\n" |
967 | "-load {\n" |
968 | "incr idx\n" |
969 | "set loadPat [lindex $args $idx]\n" |
970 | "append more \" -load $loadPat\"\n" |
971 | "}\n" |
972 | "-* {\n" |
973 | "return -code error \"unknown flag $flag: should be\\n$usage\"\n" |
974 | "}\n" |
975 | "default {\n" |
976 | "break\n" |
977 | "}\n" |
978 | "}\n" |
979 | "}\n" |
980 | "set dir [lindex $args $idx]\n" |
981 | "set patternList [lrange $args [expr {$idx + 1}] end]\n" |
982 | "if {[llength $patternList] == 0} {\n" |
983 | "set patternList [list \"*.tcl\" \"*[info sharedlibextension]\"]\n" |
984 | "}\n" |
985 | "set oldDir [pwd]\n" |
986 | "cd $dir\n" |
987 | "if {[catch {eval glob $patternList} fileList]} {\n" |
988 | "global errorCode errorInfo\n" |
989 | "cd $oldDir\n" |
990 | "return -code error -errorcode $errorCode -errorinfo $errorInfo $fileList\n" |
991 | "}\n" |
992 | "foreach file $fileList {\n" |
993 | "if {[string equal $file \"pkgIndex.tcl\"]} {\n" |
994 | "continue\n" |
995 | "}\n" |
996 | "cd $oldDir\n" |
997 | "set c [interp create]\n" |
998 | "foreach pkg [info loaded] {\n" |
999 | "if {! [string match $loadPat [lindex $pkg 1]]} {\n" |
1000 | "continue\n" |
1001 | "}\n" |
1002 | "if {[catch {\n" |
1003 | "load [lindex $pkg 0] [lindex $pkg 1] $c\n" |
1004 | "} err]} {\n" |
1005 | "if {$doVerbose} {\n" |
1006 | "tclLog \"warning: load [lindex $pkg 0] [lindex $pkg 1]\\nfailed with: $err\"\n" |
1007 | "}\n" |
1008 | "} elseif {$doVerbose} {\n" |
1009 | "tclLog \"loaded [lindex $pkg 0] [lindex $pkg 1]\"\n" |
1010 | "}\n" |
1011 | "if {[string equal [lindex $pkg 1] \"Tk\"]} {\n" |
1012 | "$c eval [list wm withdraw .]\n" |
1013 | "}\n" |
1014 | "}\n" |
1015 | "cd $dir\n" |
1016 | "$c eval {\n" |
1017 | "rename package __package_orig\n" |
1018 | "proc package {what args} {\n" |
1019 | "switch -- $what {\n" |
1020 | "require { return ; # ignore transitive requires }\n" |
1021 | "default { eval __package_orig {$what} $args }\n" |
1022 | "}\n" |
1023 | "}\n" |
1024 | "proc tclPkgUnknown args {}\n" |
1025 | "package unknown tclPkgUnknown\n" |
1026 | "proc unknown {args} {}\n" |
1027 | "proc auto_import {args} {}\n" |
1028 | "namespace eval ::tcl {\n" |
1029 | "variable file\011\011;# Current file being processed\n" |
1030 | "variable direct\011\011;# -direct flag value\n" |
1031 | "variable x\011\011;# Loop variable\n" |
1032 | "variable debug\011\011;# For debugging\n" |
1033 | "variable type\011\011;# \"load\" or \"source\", for -direct\n" |
1034 | "variable namespaces\011;# Existing namespaces (e.g., ::tcl)\n" |
1035 | "variable packages\011;# Existing packages (e.g., Tcl)\n" |
1036 | "variable origCmds\011;# Existing commands\n" |
1037 | "variable newCmds\011;# Newly created commands\n" |
1038 | "variable newPkgs {}\011;# Newly created packages\n" |
1039 | "}\n" |
1040 | "}\n" |
1041 | "$c eval [list set ::tcl::file $file]\n" |
1042 | "$c eval [list set ::tcl::direct $direct]\n" |
1043 | "foreach p {pkg_compareExtension} {\n" |
1044 | "$c eval [list proc $p [info args $p] [info body $p]]\n" |
1045 | "}\n" |
1046 | "if {[catch {\n" |
1047 | "$c eval {\n" |
1048 | "set ::tcl::debug \"loading or sourcing\"\n" |
1049 | "proc ::tcl::GetAllNamespaces {{root ::}} {\n" |
1050 | "set list $root\n" |
1051 | "foreach ns [namespace children $root] {\n" |
1052 | "eval lappend list [::tcl::GetAllNamespaces $ns]\n" |
1053 | "}\n" |
1054 | "return $list\n" |
1055 | "}\n" |
1056 | "foreach ::tcl::x [::tcl::GetAllNamespaces] {\n" |
1057 | "set ::tcl::namespaces($::tcl::x) 1\n" |
1058 | "}\n" |
1059 | "foreach ::tcl::x [package names] {\n" |
1060 | "set ::tcl::packages($::tcl::x) 1\n" |
1061 | "}\n" |
1062 | "set ::tcl::origCmds [info commands]\n" |
1063 | "if {[pkg_compareExtension $::tcl::file [info sharedlibextension]]} {\n" |
1064 | "set ::tcl::debug loading\n" |
1065 | "load [file join . $::tcl::file]\n" |
1066 | "set ::tcl::type load\n" |
1067 | "} else {\n" |
1068 | "set ::tcl::debug sourcing\n" |
1069 | "source $::tcl::file\n" |
1070 | "set ::tcl::type source\n" |
1071 | "}\n" |
1072 | "if { !$::tcl::direct } {\n" |
1073 | "foreach ::tcl::x [::tcl::GetAllNamespaces] {\n" |
1074 | "if {! [info exists ::tcl::namespaces($::tcl::x)]} {\n" |
1075 | "namespace import -force ${::tcl::x}::*\n" |
1076 | "}\n" |
1077 | "foreach ::tcl::x [info commands] {\n" |
1078 | "set ::tcl::newCmds($::tcl::x) 1\n" |
1079 | "}\n" |
1080 | "foreach ::tcl::x $::tcl::origCmds {\n" |
1081 | "catch {unset ::tcl::newCmds($::tcl::x)}\n" |
1082 | "}\n" |
1083 | "foreach ::tcl::x [array names ::tcl::newCmds] {\n" |
1084 | "set ::tcl::abs [namespace origin $::tcl::x]\n" |
1085 | "set ::tcl::abs \\\n" |
1086 | "\011\011\011\011 [lindex [auto_qualify $::tcl::abs ::] 0]\n" |
1087 | "if {[string compare $::tcl::x $::tcl::abs]} {\n" |
1088 | "set ::tcl::newCmds($::tcl::abs) 1\n" |
1089 | "unset ::tcl::newCmds($::tcl::x)\n" |
1090 | "}\n" |
1091 | "}\n" |
1092 | "}\n" |
1093 | "}\n" |
1094 | "foreach ::tcl::x [package names] {\n" |
1095 | "if {[string compare [package provide $::tcl::x] \"\"] \\\n" |
1096 | "\011\011\011 && ![info exists ::tcl::packages($::tcl::x)]} {\n" |
1097 | "lappend ::tcl::newPkgs \\\n" |
1098 | "\011\011\011 [list $::tcl::x [package provide $::tcl::x]]\n" |
1099 | "}\n" |
1100 | "}\n" |
1101 | "}\n" |
1102 | "} msg] == 1} {\n" |
1103 | "set what [$c eval set ::tcl::debug]\n" |
1104 | "if {$doVerbose} {\n" |
1105 | "tclLog \"warning: error while $what $file: $msg\"\n" |
1106 | "}\n" |
1107 | "} else {\n" |
1108 | "set type [$c eval set ::tcl::type]\n" |
1109 | "set cmds [lsort [$c eval array names ::tcl::newCmds]]\n" |
1110 | "set pkgs [$c eval set ::tcl::newPkgs]\n" |
1111 | "if {[llength $pkgs] > 1} {\n" |
1112 | "tclLog \"warning: \\\"$file\\\" provides more than one package ($pkgs)\"\n" |
1113 | "}\n" |
1114 | "foreach pkg $pkgs {\n" |
1115 | "lappend files($pkg) [list $file $type $cmds]\n" |
1116 | "}\n" |
1117 | "if {$doVerbose} {\n" |
1118 | "tclLog \"processed $file\"\n" |
1119 | "}\n" |
1120 | "interp delete $c\n" |
1121 | "}\n" |
1122 | "}\n" |
1123 | "append index \"# Tcl package index file, version 1.1\\n\"\n" |
1124 | "append index \"# This file is generated by the \\\"pkg_mkIndex$more\\\" command\\n\"\n" |
1125 | "append index \"# and sourced either when an application starts up or\\n\"\n" |
1126 | "append index \"# by a \\\"package unknown\\\" script. It invokes the\\n\"\n" |
1127 | "append index \"# \\\"package ifneeded\\\" command to set up package-related\\n\"\n" |
1128 | "append index \"# information so that packages will be loaded automatically\\n\"\n" |
1129 | "append index \"# in response to \\\"package require\\\" commands. When this\\n\"\n" |
1130 | "append index \"# script is sourced, the variable \\$dir must contain the\\n\"\n" |
1131 | "append index \"# full path name of this file's directory.\\n\"\n" |
1132 | "foreach pkg [lsort [array names files]] {\n" |
1133 | "set cmd {}\n" |
1134 | "foreach {name version} $pkg {\n" |
1135 | "break\n" |
1136 | "}\n" |
1137 | "lappend cmd ::pkg::create -name $name -version $version\n" |
1138 | "foreach spec $files($pkg) {\n" |
1139 | "foreach {file type procs} $spec {\n" |
1140 | "if { $direct } {\n" |
1141 | "set procs {}\n" |
1142 | "}\n" |
1143 | "lappend cmd \"-$type\" [list $file $procs]\n" |
1144 | "}\n" |
1145 | "}\n" |
1146 | "append index \"\\n[eval $cmd]\"\n" |
1147 | "}\n" |
1148 | "set f [open pkgIndex.tcl w]\n" |
1149 | "puts $f $index\n" |
1150 | "close $f\n" |
1151 | "cd $oldDir\n" |
1152 | "}\n" |
1153 | "proc tclPkgSetup {dir pkg version files} {\n" |
1154 | "global auto_index\n" |
1155 | "package provide $pkg $version\n" |
1156 | "foreach fileInfo $files {\n" |
1157 | "set f [lindex $fileInfo 0]\n" |
1158 | "set type [lindex $fileInfo 1]\n" |
1159 | "foreach cmd [lindex $fileInfo 2] {\n" |
1160 | "if {[string equal $type \"load\"]} {\n" |
1161 | "set auto_index($cmd) [list load [file join $dir $f] $pkg]\n" |
1162 | "} else {\n" |
1163 | "set auto_index($cmd) [list source [file join $dir $f]]\n" |
1164 | "} \n" |
1165 | "}\n" |
1166 | "}\n" |
1167 | "}\n" |
1168 | "proc tclMacPkgSearch {dir} {\n" |
1169 | "foreach x [glob -nocomplain [file join $dir *.shlb]] {\n" |
1170 | "if {[file isfile $x]} {\n" |
1171 | "set res [resource open $x]\n" |
1172 | "foreach y [resource list TEXT $res] {\n" |
1173 | "if {[string equal $y \"pkgIndex\"]} {source -rsrc pkgIndex}\n" |
1174 | "}\n" |
1175 | "catch {resource close $res}\n" |
1176 | "}\n" |
1177 | "}\n" |
1178 | "}\n" |
1179 | "proc tclPkgUnknown {name version {exact {}}} {\n" |
1180 | "global auto_path tcl_platform env\n" |
1181 | "if {![info exists auto_path]} {\n" |
1182 | "return\n" |
1183 | "}\n" |
1184 | "set old_path [set use_path $auto_path]\n" |
1185 | "while {[llength $use_path]} {\n" |
1186 | "set dir [lindex $use_path end]\n" |
1187 | "catch {\n" |
1188 | "foreach file [glob -nocomplain [file join $dir * pkgIndex.tcl]] {\n" |
1189 | "set dir [file dirname $file]\n" |
1190 | "if {[file readable $file] && ![info exists procdDirs($dir)]} {\n" |
1191 | "if {[catch {source $file} msg]} {\n" |
1192 | "tclLog \"error reading package index file $file: $msg\"\n" |
1193 | "} else {\n" |
1194 | "set procdDirs($dir) 1\n" |
1195 | "}\n" |
1196 | "}\n" |
1197 | "}\n" |
1198 | "}\n" |
1199 | "set dir [lindex $use_path end]\n" |
1200 | "set file [file join $dir pkgIndex.tcl]\n" |
1201 | "if {([interp issafe] || [file readable $file]) && \\\n" |
1202 | "\011\011![info exists procdDirs($dir)]} {\n" |
1203 | "if {[catch {source $file} msg] && ![interp issafe]} {\n" |
1204 | "tclLog \"error reading package index file $file: $msg\"\n" |
1205 | "} else {\n" |
1206 | "set procdDirs($dir) 1\n" |
1207 | "}\n" |
1208 | "}\n" |
1209 | "if {(![interp issafe]) && \\\n" |
1210 | "\011\011[string equal $tcl_platform(platform) \"macintosh\"]} {\n" |
1211 | "set dir [lindex $use_path end]\n" |
1212 | "if {![info exists procdDirs($dir)]} {\n" |
1213 | "tclMacPkgSearch $dir\n" |
1214 | "set procdDirs($dir) 1\n" |
1215 | "}\n" |
1216 | "foreach x [glob -nocomplain [file join $dir *]] {\n" |
1217 | "if {[file isdirectory $x] && ![info exists procdDirs($x)]} {\n" |
1218 | "set dir $x\n" |
1219 | "tclMacPkgSearch $dir\n" |
1220 | "set procdDirs($dir) 1\n" |
1221 | "}\n" |
1222 | "}\n" |
1223 | "}\n" |
1224 | "set use_path [lrange $use_path 0 end-1]\n" |
1225 | "if {[string compare $old_path $auto_path]} {\n" |
1226 | "foreach dir $auto_path {\n" |
1227 | "lappend use_path $dir\n" |
1228 | "}\n" |
1229 | "set old_path $auto_path\n" |
1230 | "}\n" |
1231 | "}\n" |
1232 | "}\n" |
1233 | "proc ::pkg::create {args} {\n" |
1234 | "append err(usage) \"[lindex [info level 0] 0] \"\n" |
1235 | "append err(usage) \"-name packageName -version packageVersion\"\n" |
1236 | "append err(usage) \"?-load {filename ?{procs}?}? ... \"\n" |
1237 | "append err(usage) \"?-source {filename ?{procs}?}? ...\"\n" |
1238 | "set err(wrongNumArgs) \"wrong # args: should be \\\"$err(usage)\\\"\"\n" |
1239 | "set err(valueMissing) \"value for \\\"%s\\\" missing: should be \\\"$err(usage)\\\"\"\n" |
1240 | "set err(unknownOpt) \"unknown option \\\"%s\\\": should be \\\"$err(usage)\\\"\"\n" |
1241 | "set err(noLoadOrSource) \"at least one of -load and -source must be given\"\n" |
1242 | "set len [llength $args]\n" |
1243 | "if { $len < 6 } {\n" |
1244 | "error $err(wrongNumArgs)\n" |
1245 | "}\n" |
1246 | "set opts(-name)\011\011{}\n" |
1247 | "set opts(-version)\011\011{}\n" |
1248 | "set opts(-source)\011\011{}\n" |
1249 | "set opts(-load)\011\011{}\n" |
1250 | "for {set i 0} {$i < $len} {incr i} {\n" |
1251 | "set flag [lindex $args $i]\n" |
1252 | "incr i\n" |
1253 | "switch -glob -- $flag {\n" |
1254 | "\"-name\"\011\011-\n" |
1255 | "\"-version\"\011\011{\n" |
1256 | "if { $i >= $len } {\n" |
1257 | "error [format $err(valueMissing) $flag]\n" |
1258 | "}\n" |
1259 | "set opts($flag) [lindex $args $i]\n" |
1260 | "}\n" |
1261 | "\"-source\"\011\011-\n" |
1262 | "\"-load\"\011\011{\n" |
1263 | "if { $i >= $len } {\n" |
1264 | "error [format $err(valueMissing) $flag]\n" |
1265 | "}\n" |
1266 | "lappend opts($flag) [lindex $args $i]\n" |
1267 | "}\n" |
1268 | "default {\n" |
1269 | "error [format $err(unknownOpt) [lindex $args $i]]\n" |
1270 | "}\n" |
1271 | "}\n" |
1272 | "}\n" |
1273 | "if { [llength $opts(-name)] == 0 } {\n" |
1274 | "error [format $err(valueMissing) \"-name\"]\n" |
1275 | "}\n" |
1276 | "if { [llength $opts(-version)] == 0 } {\n" |
1277 | "error [format $err(valueMissing) \"-version\"]\n" |
1278 | "}\n" |
1279 | "if { [llength $opts(-source)] == 0 && [llength $opts(-load)] == 0 } {\n" |
1280 | "error $err(noLoadOrSource)\n" |
1281 | "}\n" |
1282 | "set cmdline \"package ifneeded $opts(-name) $opts(-version) \"\n" |
1283 | "set cmdList {}\n" |
1284 | "set lazyFileList {}\n" |
1285 | "foreach key {load source} {\n" |
1286 | "foreach filespec $opts(-$key) {\n" |
1287 | "foreach {filename proclist} {{} {}} {\n" |
1288 | "break\n" |
1289 | "}\n" |
1290 | "foreach {filename proclist} $filespec {\n" |
1291 | "break\n" |
1292 | "}\n" |
1293 | "if { [llength $proclist] == 0 } {\n" |
1294 | "set cmd \"\\[list $key \\[file join \\$dir [list $filename]\\]\\]\"\n" |
1295 | "lappend cmdList $cmd\n" |
1296 | "} else {\n" |
1297 | "lappend lazyFileList [list $filename $key $proclist]\n" |
1298 | "}\n" |
1299 | "}\n" |
1300 | "}\n" |
1301 | "if { [llength $lazyFileList] > 0 } {\n" |
1302 | "lappend cmdList \"\\[list tclPkgSetup \\$dir $opts(-name)\\\n" |
1303 | "\011\011$opts(-version) [list $lazyFileList]\\]\"\n" |
1304 | "}\n" |
1305 | "append cmdline [join $cmdList \"\\\\n\"]\n" |
1306 | "return $cmdline\n" |
1307 | "}\n" |
1308 | ; |
1309 | static char Et_zFile4[] = |
1310 | "proc parray {a {pattern *}} {\n" |
1311 | "upvar 1 $a array\n" |
1312 | "if {![array exists array]} {\n" |
1313 | "error \"\\\"$a\\\" isn't an array\"\n" |
1314 | "}\n" |
1315 | "set maxl 0\n" |
1316 | "foreach name [lsort [array names array $pattern]] {\n" |
1317 | "if {[string length $name] > $maxl} {\n" |
1318 | "set maxl [string length $name]\n" |
1319 | "}\n" |
1320 | "}\n" |
1321 | "set maxl [expr {$maxl + [string length $a] + 2}]\n" |
1322 | "foreach name [lsort [array names array $pattern]] {\n" |
1323 | "set nameString [format %s(%s) $a $name]\n" |
1324 | "puts stdout [format \"%-*s = %s\" $maxl $nameString $array($name)]\n" |
1325 | "}\n" |
1326 | "}\n" |
1327 | ; |
1328 | static char Et_zFile5[] = |
1329 | "package require opt 0.4.1;\n" |
1330 | "namespace eval ::safe {\n" |
1331 | "namespace export interpCreate interpInit interpConfigure interpDelete \\\n" |
1332 | "\011 interpAddToAccessPath interpFindInAccessPath setLogCmd\n" |
1333 | "set temp [::tcl::OptKeyRegister {\n" |
1334 | "{-accessPath -list {} \"access path for the slave\"}\n" |
1335 | "{-noStatics \"prevent loading of statically linked pkgs\"}\n" |
1336 | "{-statics true \"loading of statically linked pkgs\"}\n" |
1337 | "{-nestedLoadOk \"allow nested loading\"}\n" |
1338 | "{-nested false \"nested loading\"}\n" |
1339 | "{-deleteHook -script {} \"delete hook\"}\n" |
1340 | "}]\n" |
1341 | "::tcl::OptKeyRegister {\n" |
1342 | "{?slave? -name {} \"name of the slave (optional)\"}\n" |
1343 | "} ::safe::interpCreate\n" |
1344 | "lappend ::tcl::OptDesc(::safe::interpCreate) $::tcl::OptDesc($temp)\n" |
1345 | "::tcl::OptKeyRegister {\n" |
1346 | "{slave -name {} \"name of the slave\"}\n" |
1347 | "} ::safe::interpIC\n" |
1348 | "lappend ::tcl::OptDesc(::safe::interpIC) $::tcl::OptDesc($temp)\n" |
1349 | "::tcl::OptKeyDelete $temp\n" |
1350 | "proc InterpStatics {} {\n" |
1351 | "foreach v {Args statics noStatics} {\n" |
1352 | "upvar $v $v\n" |
1353 | "}\n" |
1354 | "set flag [::tcl::OptProcArgGiven -noStatics];\n" |
1355 | "if {$flag && ($noStatics == $statics) \n" |
1356 | "&& ([::tcl::OptProcArgGiven -statics])} {\n" |
1357 | "return -code error\\\n" |
1358 | "\011\011 \"conflicting values given for -statics and -noStatics\"\n" |
1359 | "}\n" |
1360 | "if {$flag} {\n" |
1361 | "return [expr {!$noStatics}]\n" |
1362 | "} else {\n" |
1363 | "return $statics\n" |
1364 | "}\n" |
1365 | "}\n" |
1366 | "proc InterpNested {} {\n" |
1367 | "foreach v {Args nested nestedLoadOk} {\n" |
1368 | "upvar $v $v\n" |
1369 | "}\n" |
1370 | "set flag [::tcl::OptProcArgGiven -nestedLoadOk];\n" |
1371 | "if {$flag && ($nestedLoadOk != $nested) \n" |
1372 | "&& ([::tcl::OptProcArgGiven -nested])} {\n" |
1373 | "return -code error\\\n" |
1374 | "\011\011 \"conflicting values given for -nested and -nestedLoadOk\"\n" |
1375 | "}\n" |
1376 | "if {$flag} {\n" |
1377 | "return $nestedLoadOk\n" |
1378 | "} else {\n" |
1379 | "return $nested\n" |
1380 | "}\n" |
1381 | "}\n" |
1382 | "proc interpCreate {args} {\n" |
1383 | "set Args [::tcl::OptKeyParse ::safe::interpCreate $args]\n" |
1384 | "InterpCreate $slave $accessPath \\\n" |
1385 | "\011\011[InterpStatics] [InterpNested] $deleteHook\n" |
1386 | "}\n" |
1387 | "proc interpInit {args} {\n" |
1388 | "set Args [::tcl::OptKeyParse ::safe::interpIC $args]\n" |
1389 | "if {![::interp exists $slave]} {\n" |
1390 | "return -code error \"\\\"$slave\\\" is not an interpreter\"\n" |
1391 | "}\n" |
1392 | "InterpInit $slave $accessPath \\\n" |
1393 | "\011\011[InterpStatics] [InterpNested] $deleteHook;\n" |
1394 | "}\n" |
1395 | "proc CheckInterp {slave} {\n" |
1396 | "if {![IsInterp $slave]} {\n" |
1397 | "return -code error \\\n" |
1398 | "\011\011 \"\\\"$slave\\\" is not an interpreter managed by ::safe::\"\n" |
1399 | "}\n" |
1400 | "}\n" |
1401 | "proc interpConfigure {args} {\n" |
1402 | "switch [llength $args] {\n" |
1403 | "1 {\n" |
1404 | "set Args [::tcl::OptKeyParse ::safe::interpIC $args]\n" |
1405 | "CheckInterp $slave\n" |
1406 | "set res {}\n" |
1407 | "lappend res [list -accessPath [Set [PathListName $slave]]]\n" |
1408 | "lappend res [list -statics [Set [StaticsOkName $slave]]]\n" |
1409 | "lappend res [list -nested [Set [NestedOkName $slave]]]\n" |
1410 | "lappend res [list -deleteHook [Set [DeleteHookName $slave]]]\n" |
1411 | "join $res\n" |
1412 | "}\n" |
1413 | "2 {\n" |
1414 | "::tcl::Lassign $args slave arg\n" |
1415 | "set desc [lindex [::tcl::OptKeyGetDesc ::safe::interpIC] 2]\n" |
1416 | "set hits [::tcl::OptHits desc $arg]\n" |
1417 | "if {$hits > 1} {\n" |
1418 | "return -code error [::tcl::OptAmbigous $desc $arg]\n" |
1419 | "} elseif {$hits == 0} {\n" |
1420 | "return -code error [::tcl::OptFlagUsage $desc $arg]\n" |
1421 | "}\n" |
1422 | "CheckInterp $slave\n" |
1423 | "set item [::tcl::OptCurDesc $desc]\n" |
1424 | "set name [::tcl::OptName $item]\n" |
1425 | "switch -exact -- $name {\n" |
1426 | "-accessPath {\n" |
1427 | "return [list -accessPath [Set [PathListName $slave]]]\n" |
1428 | "}\n" |
1429 | "-statics {\n" |
1430 | "return [list -statics [Set [StaticsOkName $slave]]]\n" |
1431 | "}\n" |
1432 | "-nested {\n" |
1433 | "return [list -nested [Set [NestedOkName $slave]]]\n" |
1434 | "}\n" |
1435 | "-deleteHook {\n" |
1436 | "return [list -deleteHook [Set [DeleteHookName $slave]]]\n" |
1437 | "}\n" |
1438 | "-noStatics {\n" |
1439 | "return -code error\\\n" |
1440 | "\011\011\011\011\"ambigous query (get or set -noStatics ?)\\\n" |
1441 | "\011\011\011\011use -statics instead\"\n" |
1442 | "}\n" |
1443 | "-nestedLoadOk {\n" |
1444 | "return -code error\\\n" |
1445 | "\011\011\011\011\"ambigous query (get or set -nestedLoadOk ?)\\\n" |
1446 | "\011\011\011\011use -nested instead\"\n" |
1447 | "}\n" |
1448 | "default {\n" |
1449 | "return -code error \"unknown flag $name (bug)\"\n" |
1450 | "}\n" |
1451 | "}\n" |
1452 | "}\n" |
1453 | "default {\n" |
1454 | "set Args [::tcl::OptKeyParse ::safe::interpIC $args]\n" |
1455 | "CheckInterp $slave\n" |
1456 | "if {![::tcl::OptProcArgGiven -accessPath]} {\n" |
1457 | "set doreset 1\n" |
1458 | "set accessPath [Set [PathListName $slave]]\n" |
1459 | "} else {\n" |
1460 | "set doreset 0\n" |
1461 | "}\n" |
1462 | "if {(![::tcl::OptProcArgGiven -statics]) \\\n" |
1463 | "\011\011\011&& (![::tcl::OptProcArgGiven -noStatics]) } {\n" |
1464 | "set statics [Set [StaticsOkName $slave]]\n" |
1465 | "} else {\n" |
1466 | "set statics [InterpStatics]\n" |
1467 | "}\n" |
1468 | "if {([::tcl::OptProcArgGiven -nested]) \\\n" |
1469 | "\011\011\011|| ([::tcl::OptProcArgGiven -nestedLoadOk]) } {\n" |
1470 | "set nested [InterpNested]\n" |
1471 | "} else {\n" |
1472 | "set nested [Set [NestedOkName $slave]]\n" |
1473 | "}\n" |
1474 | "if {![::tcl::OptProcArgGiven -deleteHook]} {\n" |
1475 | "set deleteHook [Set [DeleteHookName $slave]]\n" |
1476 | "}\n" |
1477 | "InterpSetConfig $slave $accessPath $statics $nested $deleteHook\n" |
1478 | "if {$doreset} {\n" |
1479 | "if {[catch {::interp eval $slave {auto_reset}} msg]} {\n" |
1480 | "Log $slave \"auto_reset failed: $msg\"\n" |
1481 | "} else {\n" |
1482 | "Log $slave \"successful auto_reset\" NOTICE\n" |
1483 | "}\n" |
1484 | "}\n" |
1485 | "}\n" |
1486 | "}\n" |
1487 | "}\n" |
1488 | "proc ::safe::InterpCreate {\n" |
1489 | "slave \n" |
1490 | "access_path\n" |
1491 | "staticsok\n" |
1492 | "nestedok\n" |
1493 | "deletehook\n" |
1494 | "} {\n" |
1495 | "if {[string compare \"\" $slave]} {\n" |
1496 | "::interp create -safe $slave\n" |
1497 | "} else {\n" |
1498 | "set slave [::interp create -safe]\n" |
1499 | "}\n" |
1500 | "Log $slave \"Created\" NOTICE\n" |
1501 | "InterpInit $slave $access_path $staticsok $nestedok $deletehook\n" |
1502 | "}\n" |
1503 | "proc ::safe::InterpSetConfig {slave access_path staticsok\\\n" |
1504 | "\011 nestedok deletehook} {\n" |
1505 | "if {[string equal \"\" $access_path]} {\n" |
1506 | "set access_path [uplevel #0 set auto_path]\n" |
1507 | "set where [lsearch -exact $access_path [info library]]\n" |
1508 | "if {$where == -1} {\n" |
1509 | "set access_path [concat [list [info library]] $access_path]\n" |
1510 | "Log $slave \"tcl_library was not in auto_path,\\\n" |
1511 | "\011\011\011added it to slave's access_path\" NOTICE\n" |
1512 | "} elseif {$where != 0} {\n" |
1513 | "set access_path [concat [list [info library]]\\\n" |
1514 | "\011\011\011[lreplace $access_path $where $where]]\n" |
1515 | "Log $slave \"tcl_libray was not in first in auto_path,\\\n" |
1516 | "\011\011\011moved it to front of slave's access_path\" NOTICE\n" |
1517 | "}\n" |
1518 | "set access_path [AddSubDirs $access_path]\n" |
1519 | "}\n" |
1520 | "Log $slave \"Setting accessPath=($access_path) staticsok=$staticsok\\\n" |
1521 | "\011\011nestedok=$nestedok deletehook=($deletehook)\" NOTICE\n" |
1522 | "set nname [PathNumberName $slave]\n" |
1523 | "if {[Exists $nname]} {\n" |
1524 | "set n [Set $nname]\n" |
1525 | "for {set i 0} {$i<$n} {incr i} {\n" |
1526 | "Unset [PathToken $i $slave]\n" |
1527 | "}\n" |
1528 | "}\n" |
1529 | "set slave_auto_path {}\n" |
1530 | "set i 0\n" |
1531 | "foreach dir $access_path {\n" |
1532 | "Set [PathToken $i $slave] $dir\n" |
1533 | "lappend slave_auto_path \"\\$[PathToken $i]\"\n" |
1534 | "incr i\n" |
1535 | "}\n" |
1536 | "Set $nname $i\n" |
1537 | "Set [PathListName $slave] $access_path\n" |
1538 | "Set [VirtualPathListName $slave] $slave_auto_path\n" |
1539 | "Set [StaticsOkName $slave] $staticsok\n" |
1540 | "Set [NestedOkName $slave] $nestedok\n" |
1541 | "Set [DeleteHookName $slave] $deletehook\n" |
1542 | "SyncAccessPath $slave\n" |
1543 | "}\n" |
1544 | "proc ::safe::interpFindInAccessPath {slave path} {\n" |
1545 | "set access_path [GetAccessPath $slave]\n" |
1546 | "set where [lsearch -exact $access_path $path]\n" |
1547 | "if {$where == -1} {\n" |
1548 | "return -code error \"$path not found in access path $access_path\"\n" |
1549 | "}\n" |
1550 | "return \"\\$[PathToken $where]\"\n" |
1551 | "}\n" |
1552 | "proc ::safe::interpAddToAccessPath {slave path} {\n" |
1553 | "if {![catch {interpFindInAccessPath $slave $path} res]} {\n" |
1554 | "return $res\n" |
1555 | "}\n" |
1556 | "set nname [PathNumberName $slave]\n" |
1557 | "set n [Set $nname]\n" |
1558 | "Set [PathToken $n $slave] $path\n" |
1559 | "set token \"\\$[PathToken $n]\"\n" |
1560 | "Lappend [VirtualPathListName $slave] $token\n" |
1561 | "Lappend [PathListName $slave] $path\n" |
1562 | "Set $nname [expr {$n+1}]\n" |
1563 | "SyncAccessPath $slave\n" |
1564 | "return $token\n" |
1565 | "}\n" |
1566 | "proc ::safe::InterpInit {\n" |
1567 | "slave \n" |
1568 | "access_path\n" |
1569 | "staticsok\n" |
1570 | "nestedok\n" |
1571 | "deletehook\n" |
1572 | "} {\n" |
1573 | "InterpSetConfig $slave $access_path $staticsok $nestedok $deletehook\n" |
1574 | "::interp alias $slave source {} [namespace current]::AliasSource $slave\n" |
1575 | "::interp alias $slave load {} [namespace current]::AliasLoad $slave\n" |
1576 | "::interp alias $slave encoding {} [namespace current]::AliasEncoding \\\n" |
1577 | "\011\011$slave\n" |
1578 | "AliasSubset $slave file file dir.* join root.* ext.* tail \\\n" |
1579 | "\011\011path.* split\n" |
1580 | "::interp alias $slave exit {} [namespace current]::interpDelete $slave\n" |
1581 | "if {[catch {::interp eval $slave\\\n" |
1582 | "\011\011{source [file join $tcl_library init.tcl]}} msg]} {\n" |
1583 | "Log $slave \"can't source init.tcl ($msg)\"\n" |
1584 | "error \"can't source init.tcl into slave $slave ($msg)\"\n" |
1585 | "}\n" |
1586 | "return $slave\n" |
1587 | "}\n" |
1588 | "proc AddSubDirs {pathList} {\n" |
1589 | "set res {}\n" |
1590 | "foreach dir $pathList {\n" |
1591 | "if {[file isdirectory $dir]} {\n" |
1592 | "if {[lsearch -exact $res $dir]<0} {\n" |
1593 | "lappend res $dir\n" |
1594 | "}\n" |
1595 | "foreach sub [glob -nocomplain -- [file join $dir *]] {\n" |
1596 | "if {([file isdirectory $sub]) \\\n" |
1597 | "\011\011\011 && ([lsearch -exact $res $sub]<0) } {\n" |
1598 | "lappend res $sub\n" |
1599 | "}\n" |
1600 | "}\n" |
1601 | "}\n" |
1602 | "}\n" |
1603 | "return $res\n" |
1604 | "}\n" |
1605 | "proc ::safe::interpDelete {slave} {\n" |
1606 | "Log $slave \"About to delete\" NOTICE\n" |
1607 | "set hookname [DeleteHookName $slave]\n" |
1608 | "if {[Exists $hookname]} {\n" |
1609 | "set hook [Set $hookname]\n" |
1610 | "if {![::tcl::Lempty $hook]} {\n" |
1611 | "Unset $hookname\n" |
1612 | "if {[catch {eval $hook [list $slave]} err]} {\n" |
1613 | "Log $slave \"Delete hook error ($err)\"\n" |
1614 | "}\n" |
1615 | "}\n" |
1616 | "}\n" |
1617 | "set statename [InterpStateName $slave]\n" |
1618 | "if {[Exists $statename]} {\n" |
1619 | "Unset $statename\n" |
1620 | "}\n" |
1621 | "if {[::interp exists $slave]} {\n" |
1622 | "::interp delete $slave\n" |
1623 | "Log $slave \"Deleted\" NOTICE\n" |
1624 | "}\n" |
1625 | "return\n" |
1626 | "}\n" |
1627 | "proc ::safe::setLogCmd {args} {\n" |
1628 | "variable Log\n" |
1629 | "if {[llength $args] == 0} {\n" |
1630 | "return $Log\n" |
1631 | "} else {\n" |
1632 | "if {[llength $args] == 1} {\n" |
1633 | "set Log [lindex $args 0]\n" |
1634 | "} else {\n" |
1635 | "set Log $args\n" |
1636 | "}\n" |
1637 | "}\n" |
1638 | "}\n" |
1639 | "variable Log {}\n" |
1640 | "proc SyncAccessPath {slave} {\n" |
1641 | "set slave_auto_path [Set [VirtualPathListName $slave]]\n" |
1642 | "::interp eval $slave [list set auto_path $slave_auto_path]\n" |
1643 | "Log $slave \"auto_path in $slave has been set to $slave_auto_path\"\\\n" |
1644 | "\011\011NOTICE\n" |
1645 | "::interp eval $slave [list set tcl_library [lindex $slave_auto_path 0]]\n" |
1646 | "}\n" |
1647 | "proc InterpStateName {slave} {\n" |
1648 | "return \"S$slave\"\n" |
1649 | "}\n" |
1650 | "proc IsInterp {slave} {\n" |
1651 | "expr {[Exists [InterpStateName $slave]] && [::interp exists $slave]}\n" |
1652 | "}\n" |
1653 | "proc PathToken {n {slave \"\"}} {\n" |
1654 | "if {[string compare \"\" $slave]} {\n" |
1655 | "return \"[InterpStateName $slave](access_path,$n)\"\n" |
1656 | "} else {\n" |
1657 | "return \"p(:$n:)\"\n" |
1658 | "}\n" |
1659 | "}\n" |
1660 | "proc PathListName {slave} {\n" |
1661 | "return \"[InterpStateName $slave](access_path)\"\n" |
1662 | "}\n" |
1663 | "proc VirtualPathListName {slave} {\n" |
1664 | "return \"[InterpStateName $slave](access_path_slave)\"\n" |
1665 | "}\n" |
1666 | "proc PathNumberName {slave} {\n" |
1667 | "return \"[InterpStateName $slave](access_path,n)\"\n" |
1668 | "}\n" |
1669 | "proc StaticsOkName {slave} {\n" |
1670 | "return \"[InterpStateName $slave](staticsok)\"\n" |
1671 | "}\n" |
1672 | "proc NestedOkName {slave} {\n" |
1673 | "return \"[InterpStateName $slave](nestedok)\"\n" |
1674 | "}\n" |
1675 | "proc Toplevel {args} {\n" |
1676 | "namespace eval [namespace current] $args\n" |
1677 | "}\n" |
1678 | "proc Set {args} {\n" |
1679 | "eval Toplevel set $args\n" |
1680 | "}\n" |
1681 | "proc Lappend {args} {\n" |
1682 | "eval Toplevel lappend $args\n" |
1683 | "}\n" |
1684 | "proc Unset {args} {\n" |
1685 | "eval Toplevel unset $args\n" |
1686 | "}\n" |
1687 | "proc Exists {varname} {\n" |
1688 | "Toplevel info exists $varname\n" |
1689 | "}\n" |
1690 | "proc GetAccessPath {slave} {\n" |
1691 | "Set [PathListName $slave]\n" |
1692 | "}\n" |
1693 | "proc StaticsOk {slave} {\n" |
1694 | "Set [StaticsOkName $slave]\n" |
1695 | "}\n" |
1696 | "proc NestedOk {slave} {\n" |
1697 | "Set [NestedOkName $slave]\n" |
1698 | "}\n" |
1699 | "proc DeleteHookName {slave} {\n" |
1700 | "return [InterpStateName $slave](cleanupHook)\n" |
1701 | "}\n" |
1702 | "proc TranslatePath {slave path} {\n" |
1703 | "if {[regexp {(::)|(\\.\\.)} $path]} {\n" |
1704 | "error \"invalid characters in path $path\"\n" |
1705 | "}\n" |
1706 | "set n [expr {[Set [PathNumberName $slave]]-1}]\n" |
1707 | "for {} {$n>=0} {incr n -1} {\n" |
1708 | "set [PathToken $n] [Set [PathToken $n $slave]]\n" |
1709 | "}\n" |
1710 | "subst -nobackslashes -nocommands $path\n" |
1711 | "}\n" |
1712 | "proc Log {slave msg {type ERROR}} {\n" |
1713 | "variable Log\n" |
1714 | "if {[info exists Log] && [llength $Log]} {\n" |
1715 | "eval $Log [list \"$type for slave $slave : $msg\"]\n" |
1716 | "}\n" |
1717 | "}\n" |
1718 | "proc CheckFileName {slave file} {\n" |
1719 | "set ftail [file tail $file]\n" |
1720 | "if {[string length $ftail]>14} {\n" |
1721 | "error \"$ftail: filename too long\"\n" |
1722 | "}\n" |
1723 | "if {[regexp {\\..*\\.} $ftail]} {\n" |
1724 | "error \"$ftail: more than one dot is forbidden\"\n" |
1725 | "}\n" |
1726 | "if {[string compare $ftail \"tclIndex\"] && \\\n" |
1727 | "\011\011[string compare -nocase [file extension $ftail]\011\".tcl\"]} {\n" |
1728 | "error \"$ftail: must be a *.tcl or tclIndex\"\n" |
1729 | "}\n" |
1730 | "if {![file exists $file]} {\n" |
1731 | "error \"no such file or directory\"\n" |
1732 | "}\n" |
1733 | "if {![file readable $file]} {\n" |
1734 | "error \"not readable\"\n" |
1735 | "}\n" |
1736 | "}\n" |
1737 | "proc AliasSource {slave args} {\n" |
1738 | "set argc [llength $args]\n" |
1739 | "if {$argc != 1} {\n" |
1740 | "set msg \"wrong # args: should be \\\"source fileName\\\"\"\n" |
1741 | "Log $slave \"$msg ($args)\"\n" |
1742 | "return -code error $msg\n" |
1743 | "}\n" |
1744 | "set file [lindex $args 0]\n" |
1745 | "if {[catch {set file [TranslatePath $slave $file]} msg]} {\n" |
1746 | "Log $slave $msg\n" |
1747 | "return -code error \"permission denied\"\n" |
1748 | "}\n" |
1749 | "if {[catch {FileInAccessPath $slave $file} msg]} {\n" |
1750 | "Log $slave $msg\n" |
1751 | "return -code error \"permission denied\"\n" |
1752 | "}\n" |
1753 | "if {[catch {CheckFileName $slave $file} msg]} {\n" |
1754 | "Log $slave \"$file:$msg\"\n" |
1755 | "return -code error $msg\n" |
1756 | "}\n" |
1757 | "if {[catch {::interp invokehidden $slave source $file} msg]} {\n" |
1758 | "Log $slave $msg\n" |
1759 | "return -code error \"script error\"\n" |
1760 | "}\n" |
1761 | "return $msg\n" |
1762 | "}\n" |
1763 | "proc AliasLoad {slave file args} {\n" |
1764 | "set argc [llength $args]\n" |
1765 | "if {$argc > 2} {\n" |
1766 | "set msg \"load error: too many arguments\"\n" |
1767 | "Log $slave \"$msg ($argc) {$file $args}\"\n" |
1768 | "return -code error $msg\n" |
1769 | "}\n" |
1770 | "set package [lindex $args 0]\n" |
1771 | "set target [lindex $args 1]\n" |
1772 | "if {[string length $target]} {\n" |
1773 | "if {![NestedOk $slave]} {\n" |
1774 | "Log $slave \"loading to a sub interp (nestedok)\\\n" |
1775 | "\011\011\011disabled (trying to load $package to $target)\"\n" |
1776 | "return -code error \"permission denied (nested load)\"\n" |
1777 | "}\n" |
1778 | "}\n" |
1779 | "if {[string length $file] == 0} {\n" |
1780 | "if {[string length $package] == 0} {\n" |
1781 | "set msg \"load error: empty filename and no package name\"\n" |
1782 | "Log $slave $msg\n" |
1783 | "return -code error $msg\n" |
1784 | "}\n" |
1785 | "if {![StaticsOk $slave]} {\n" |
1786 | "Log $slave \"static packages loading disabled\\\n" |
1787 | "\011\011\011(trying to load $package to $target)\"\n" |
1788 | "return -code error \"permission denied (static package)\"\n" |
1789 | "}\n" |
1790 | "} else {\n" |
1791 | "if {[catch {set file [TranslatePath $slave $file]} msg]} {\n" |
1792 | "Log $slave $msg\n" |
1793 | "return -code error \"permission denied\"\n" |
1794 | "}\n" |
1795 | "if {[catch {FileInAccessPath $slave $file} msg]} {\n" |
1796 | "Log $slave $msg\n" |
1797 | "return -code error \"permission denied (path)\"\n" |
1798 | "}\n" |
1799 | "}\n" |
1800 | "if {[catch {::interp invokehidden\\\n" |
1801 | "\011\011$slave load $file $package $target} msg]} {\n" |
1802 | "Log $slave $msg\n" |
1803 | "return -code error $msg\n" |
1804 | "}\n" |
1805 | "return $msg\n" |
1806 | "}\n" |
1807 | "proc FileInAccessPath {slave file} {\n" |
1808 | "set access_path [GetAccessPath $slave]\n" |
1809 | "if {[file isdirectory $file]} {\n" |
1810 | "error \"\\\"$file\\\": is a directory\"\n" |
1811 | "}\n" |
1812 | "set parent [file dirname $file]\n" |
1813 | "if {[lsearch -exact $access_path $parent] == -1} {\n" |
1814 | "error \"\\\"$file\\\": not in access_path\"\n" |
1815 | "}\n" |
1816 | "}\n" |
1817 | "proc Subset {slave command okpat args} {\n" |
1818 | "set subcommand [lindex $args 0]\n" |
1819 | "if {[regexp $okpat $subcommand]} {\n" |
1820 | "return [eval {$command $subcommand} [lrange $args 1 end]]\n" |
1821 | "}\n" |
1822 | "set msg \"not allowed to invoke subcommand $subcommand of $command\"\n" |
1823 | "Log $slave $msg\n" |
1824 | "error $msg\n" |
1825 | "}\n" |
1826 | "proc AliasSubset {slave alias target args} {\n" |
1827 | "set pat ^(; set sep \"\"\n" |
1828 | "foreach sub $args {\n" |
1829 | "append pat $sep$sub\n" |
1830 | "set sep |\n" |
1831 | "}\n" |
1832 | "append pat )\\$\n" |
1833 | "::interp alias $slave $alias {}\\\n" |
1834 | "\011\011[namespace current]::Subset $slave $target $pat\n" |
1835 | "}\n" |
1836 | "proc AliasEncoding {slave args} {\n" |
1837 | "set argc [llength $args]\n" |
1838 | "set okpat \"^(name.*|convert.*)\\$\"\n" |
1839 | "set subcommand [lindex $args 0]\n" |
1840 | "if {[regexp $okpat $subcommand]} {\n" |
1841 | "return [eval ::interp invokehidden $slave encoding $subcommand \\\n" |
1842 | "\011\011 [lrange $args 1 end]]\n" |
1843 | "}\n" |
1844 | "if {[string match $subcommand system]} {\n" |
1845 | "if {$argc == 1} {\n" |
1846 | "if {[catch {::interp invokehidden \\\n" |
1847 | "\011\011\011$slave encoding system} msg]} {\n" |
1848 | "Log $slave $msg\n" |
1849 | "return -code error \"script error\"\n" |
1850 | "}\n" |
1851 | "} else {\n" |
1852 | "set msg \"wrong # args: should be \\\"encoding system\\\"\"\n" |
1853 | "Log $slave $msg\n" |
1854 | "error $msg\n" |
1855 | "}\n" |
1856 | "} else {\n" |
1857 | "set msg \"wrong # args: should be \\\"encoding option ?arg ...?\\\"\"\n" |
1858 | "Log $slave $msg\n" |
1859 | "error $msg\n" |
1860 | "}\n" |
1861 | "return $msg\n" |
1862 | "}\n" |
1863 | "}\n" |
1864 | ; |
1865 | static char Et_zFile6[] = |
1866 | "# Tcl autoload index file, version 2.0\n" |
1867 | "# This file is generated by the \"auto_mkindex\" command\n" |
1868 | "# and sourced to set up indexing information for one or\n" |
1869 | "# more commands. Typically each line is a command that\n" |
1870 | "# sets an element in the auto_index array, where the\n" |
1871 | "# element name is the name of a command and the value is\n" |
1872 | "# a script that loads the command.\n" |
1873 | "\n" |
1874 | "set auto_index(auto_reset) [list source [file join $dir auto.tcl]]\n" |
1875 | "set auto_index(tcl_findLibrary) [list source [file join $dir auto.tcl]]\n" |
1876 | "set auto_index(auto_mkindex) [list source [file join $dir auto.tcl]]\n" |
1877 | "set auto_index(auto_mkindex_old) [list source [file join $dir auto.tcl]]\n" |
1878 | "set auto_index(::auto_mkindex_parser::init) [list source [file join $dir auto.tcl]]\n" |
1879 | "set auto_index(::auto_mkindex_parser::cleanup) [list source [file join $dir auto.tcl]]\n" |
1880 | "set auto_index(::auto_mkindex_parser::mkindex) [list source [file join $dir auto.tcl]]\n" |
1881 | "set auto_index(::auto_mkindex_parser::hook) [list source [file join $dir auto.tcl]]\n" |
1882 | "set auto_index(::auto_mkindex_parser::slavehook) [list source [file join $dir auto.tcl]]\n" |
1883 | "set auto_index(::auto_mkindex_parser::command) [list source [file join $dir auto.tcl]]\n" |
1884 | "set auto_index(::auto_mkindex_parser::commandInit) [list source [file join $dir auto.tcl]]\n" |
1885 | "set auto_index(::auto_mkindex_parser::fullname) [list source [file join $dir auto.tcl]]\n" |
1886 | "set auto_index(history) [list source [file join $dir history.tcl]]\n" |
1887 | "set auto_index(::tcl::HistAdd) [list source [file join $dir history.tcl]]\n" |
1888 | "set auto_index(::tcl::HistKeep) [list source [file join $dir history.tcl]]\n" |
1889 | "set auto_index(::tcl::HistClear) [list source [file join $dir history.tcl]]\n" |
1890 | "set auto_index(::tcl::HistInfo) [list source [file join $dir history.tcl]]\n" |
1891 | "set auto_index(::tcl::HistRedo) [list source [file join $dir history.tcl]]\n" |
1892 | "set auto_index(::tcl::HistIndex) [list source [file join $dir history.tcl]]\n" |
1893 | "set auto_index(::tcl::HistEvent) [list source [file join $dir history.tcl]]\n" |
1894 | "set auto_index(::tcl::HistChange) [list source [file join $dir history.tcl]]\n" |
1895 | "set auto_index(tclLdAout) [list source [file join $dir ldAout.tcl]]\n" |
1896 | "set auto_index(pkg_compareExtension) [list source [file join $dir package.tcl]]\n" |
1897 | "set auto_index(pkg_mkIndex) [list source [file join $dir package.tcl]]\n" |
1898 | "set auto_index(tclPkgSetup) [list source [file join $dir package.tcl]]\n" |
1899 | "set auto_index(tclMacPkgSearch) [list source [file join $dir package.tcl]]\n" |
1900 | "set auto_index(tclPkgUnknown) [list source [file join $dir package.tcl]]\n" |
1901 | "set auto_index(::pkg::create) [list source [file join $dir package.tcl]]\n" |
1902 | "set auto_index(parray) [list source [file join $dir parray.tcl]]\n" |
1903 | "set auto_index(::safe::InterpStatics) [list source [file join $dir safe.tcl]]\n" |
1904 | "set auto_index(::safe::InterpNested) [list source [file join $dir safe.tcl]]\n" |
1905 | "set auto_index(::safe::interpCreate) [list source [file join $dir safe.tcl]]\n" |
1906 | "set auto_index(::safe::interpInit) [list source [file join $dir safe.tcl]]\n" |
1907 | "set auto_index(::safe::CheckInterp) [list source [file join $dir safe.tcl]]\n" |
1908 | "set auto_index(::safe::interpConfigure) [list source [file join $dir safe.tcl]]\n" |
1909 | "set auto_index(::safe::InterpCreate) [list source [file join $dir safe.tcl]]\n" |
1910 | "set auto_index(::safe::InterpSetConfig) [list source [file join $dir safe.tcl]]\n" |
1911 | "set auto_index(::safe::interpFindInAccessPath) [list source [file join $dir safe.tcl]]\n" |
1912 | "set auto_index(::safe::interpAddToAccessPath) [list source [file join $dir safe.tcl]]\n" |
1913 | "set auto_index(::safe::InterpInit) [list source [file join $dir safe.tcl]]\n" |
1914 | "set auto_index(::safe::AddSubDirs) [list source [file join $dir safe.tcl]]\n" |
1915 | "set auto_index(::safe::interpDelete) [list source [file join $dir safe.tcl]]\n" |
1916 | "set auto_index(::safe::setLogCmd) [list source [file join $dir safe.tcl]]\n" |
1917 | "set auto_index(::safe::SyncAccessPath) [list source [file join $dir safe.tcl]]\n" |
1918 | "set auto_index(::safe::InterpStateName) [list source [file join $dir safe.tcl]]\n" |
1919 | "set auto_index(::safe::IsInterp) [list source [file join $dir safe.tcl]]\n" |
1920 | "set auto_index(::safe::PathToken) [list source [file join $dir safe.tcl]]\n" |
1921 | "set auto_index(::safe::PathListName) [list source [file join $dir safe.tcl]]\n" |
1922 | "set auto_index(::safe::VirtualPathListName) [list source [file join $dir safe.tcl]]\n" |
1923 | "set auto_index(::safe::PathNumberName) [list source [file join $dir safe.tcl]]\n" |
1924 | "set auto_index(::safe::StaticsOkName) [list source [file join $dir safe.tcl]]\n" |
1925 | "set auto_index(::safe::NestedOkName) [list source [file join $dir safe.tcl]]\n" |
1926 | "set auto_index(::safe::Toplevel) [list source [file join $dir safe.tcl]]\n" |
1927 | "set auto_index(::safe::Set) [list source [file join $dir safe.tcl]]\n" |
1928 | "set auto_index(::safe::Lappend) [list source [file join $dir safe.tcl]]\n" |
1929 | "set auto_index(::safe::Unset) [list source [file join $dir safe.tcl]]\n" |
1930 | "set auto_index(::safe::Exists) [list source [file join $dir safe.tcl]]\n" |
1931 | "set auto_index(::safe::GetAccessPath) [list source [file join $dir safe.tcl]]\n" |
1932 | "set auto_index(::safe::StaticsOk) [list source [file join $dir safe.tcl]]\n" |
1933 | "set auto_index(::safe::NestedOk) [list source [file join $dir safe.tcl]]\n" |
1934 | "set auto_index(::safe::DeleteHookName) [list source [file join $dir safe.tcl]]\n" |
1935 | "set auto_index(::safe::TranslatePath) [list source [file join $dir safe.tcl]]\n" |
1936 | "set auto_index(::safe::Log) [list source [file join $dir safe.tcl]]\n" |
1937 | "set auto_index(::safe::CheckFileName) [list source [file join $dir safe.tcl]]\n" |
1938 | "set auto_index(::safe::AliasSource) [list source [file join $dir safe.tcl]]\n" |
1939 | "set auto_index(::safe::AliasLoad) [list source [file join $dir safe.tcl]]\n" |
1940 | "set auto_index(::safe::FileInAccessPath) [list source [file join $dir safe.tcl]]\n" |
1941 | "set auto_index(::safe::Subset) [list source [file join $dir safe.tcl]]\n" |
1942 | "set auto_index(::safe::AliasSubset) [list source [file join $dir safe.tcl]]\n" |
1943 | "set auto_index(tcl_wordBreakAfter) [list source [file join $dir word.tcl]]\n" |
1944 | "set auto_index(tcl_wordBreakBefore) [list source [file join $dir word.tcl]]\n" |
1945 | "set auto_index(tcl_endOfWord) [list source [file join $dir word.tcl]]\n" |
1946 | "set auto_index(tcl_startOfNextWord) [list source [file join $dir word.tcl]]\n" |
1947 | "set auto_index(tcl_startOfPreviousWord) [list source [file join $dir word.tcl]]\n" |
1948 | ; |
1949 | static char Et_zFile7[] = |
1950 | "if {[string equal $tcl_platform(platform) \"windows\"]} {\n" |
1951 | "set tcl_wordchars \"\\\\S\"\n" |
1952 | "set tcl_nonwordchars \"\\\\s\"\n" |
1953 | "} else {\n" |
1954 | "set tcl_wordchars \"\\\\w\"\n" |
1955 | "set tcl_nonwordchars \"\\\\W\"\n" |
1956 | "}\n" |
1957 | "proc tcl_wordBreakAfter {str start} {\n" |
1958 | "global tcl_nonwordchars tcl_wordchars\n" |
1959 | "set str [string range $str $start end]\n" |
1960 | "if {[regexp -indices \"$tcl_wordchars$tcl_nonwordchars|$tcl_nonwordchars$tcl_wordchars\" $str result]} {\n" |
1961 | "return [expr {[lindex $result 1] + $start}]\n" |
1962 | "}\n" |
1963 | "return -1\n" |
1964 | "}\n" |
1965 | "proc tcl_wordBreakBefore {str start} {\n" |
1966 | "global tcl_nonwordchars tcl_wordchars\n" |
1967 | "if {[string equal $start end]} {\n" |
1968 | "set start [string length $str]\n" |
1969 | "}\n" |
1970 | "if {[regexp -indices \"^.*($tcl_wordchars$tcl_nonwordchars|$tcl_nonwordchars$tcl_wordchars)\" [string range $str 0 $start] result]} {\n" |
1971 | "return [lindex $result 1]\n" |
1972 | "}\n" |
1973 | "return -1\n" |
1974 | "}\n" |
1975 | "proc tcl_endOfWord {str start} {\n" |
1976 | "global tcl_nonwordchars tcl_wordchars\n" |
1977 | "if {[regexp -indices \"$tcl_nonwordchars*$tcl_wordchars+$tcl_nonwordchars\" \\\n" |
1978 | "\011 [string range $str $start end] result]} {\n" |
1979 | "return [expr {[lindex $result 1] + $start}]\n" |
1980 | "}\n" |
1981 | "return -1\n" |
1982 | "}\n" |
1983 | "proc tcl_startOfNextWord {str start} {\n" |
1984 | "global tcl_nonwordchars tcl_wordchars\n" |
1985 | "if {[regexp -indices \"$tcl_wordchars*$tcl_nonwordchars+$tcl_wordchars\" \\\n" |
1986 | "\011 [string range $str $start end] result]} {\n" |
1987 | "return [expr {[lindex $result 1] + $start}]\n" |
1988 | "}\n" |
1989 | "return -1\n" |
1990 | "}\n" |
1991 | "proc tcl_startOfPreviousWord {str start} {\n" |
1992 | "global tcl_nonwordchars tcl_wordchars\n" |
1993 | "if {[string equal $start end]} {\n" |
1994 | "set start [string length $str]\n" |
1995 | "}\n" |
1996 | "if {[regexp -indices \\\n" |
1997 | "\011 \"$tcl_nonwordchars*($tcl_wordchars+)$tcl_nonwordchars*\\$\" \\\n" |
1998 | "\011 [string range $str 0 [expr {$start - 1}]] result word]} {\n" |
1999 | "return [lindex $word 0]\n" |
2000 | "}\n" |
2001 | "return -1\n" |
2002 | "}\n" |
2003 | ; |
2004 | static char Et_zFile8[] = |
2005 | "proc bgerror err {\n" |
2006 | "global errorInfo tcl_platform\n" |
2007 | "set info $errorInfo ;\n" |
2008 | "set ret [catch {tkerror $err} msg];\n" |
2009 | "if {$ret != 1} {return -code $ret $msg}\n" |
2010 | "if {$tcl_platform(platform) == \"macintosh\"} {\n" |
2011 | "set ok Ok\n" |
2012 | "} else {\n" |
2013 | "set ok OK\n" |
2014 | "}\n" |
2015 | "set button [tk_dialog .bgerrorDialog \"Error in Tcl Script\" \\\n" |
2016 | "\011 \"Error: $err\" error 0 $ok \"Skip Messages\" \"Stack Trace\"]\n" |
2017 | "if {$button == 0} {\n" |
2018 | "return\n" |
2019 | "} elseif {$button == 1} {\n" |
2020 | "return -code break\n" |
2021 | "}\n" |
2022 | "set w .bgerrorTrace\n" |
2023 | "catch {destroy $w}\n" |
2024 | "toplevel $w -class ErrorTrace\n" |
2025 | "wm minsize $w 1 1\n" |
2026 | "wm title $w \"Stack Trace for Error\"\n" |
2027 | "wm iconname $w \"Stack Trace\"\n" |
2028 | "button $w.ok -text OK -command \"destroy $w\" -default active\n" |
2029 | "if {![string compare $tcl_platform(platform) \"macintosh\"]} {\n" |
2030 | "text $w.text -relief flat -bd 2 -highlightthickness 0 -setgrid true \\\n" |
2031 | "\011 -yscrollcommand \"$w.scroll set\" -width 60 -height 20\n" |
2032 | "} else {\n" |
2033 | "text $w.text -relief sunken -bd 2 -yscrollcommand \"$w.scroll set\" \\\n" |
2034 | "\011 -setgrid true -width 60 -height 20\n" |
2035 | "}\n" |
2036 | "scrollbar $w.scroll -relief sunken -command \"$w.text yview\"\n" |
2037 | "pack $w.ok -side bottom -padx 3m -pady 2m\n" |
2038 | "pack $w.scroll -side right -fill y\n" |
2039 | "pack $w.text -side left -expand yes -fill both\n" |
2040 | "$w.text insert 0.0 $info\n" |
2041 | "$w.text mark set insert 0.0\n" |
2042 | "bind $w <Return> \"destroy $w\"\n" |
2043 | "bind $w.text <Return> \"destroy $w; break\"\n" |
2044 | "wm withdraw $w\n" |
2045 | "update idletasks\n" |
2046 | "set x [expr {[winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \\\n" |
2047 | "\011 - [winfo vrootx [winfo parent $w]]}]\n" |
2048 | "set y [expr {[winfo screenheight $w]/2 - [winfo reqheight $w]/2 \\\n" |
2049 | "\011 - [winfo vrooty [winfo parent $w]]}]\n" |
2050 | "wm geom $w +$x+$y\n" |
2051 | "wm deiconify $w\n" |
2052 | "if {[string compare [grab current .] \"\"]} {\n" |
2053 | "grab release [grab current .]\n" |
2054 | "}\n" |
2055 | "}\n" |
2056 | ; |
2057 | static char Et_zFile9[] = |
2058 | "if {[string match \"macintosh\" $tcl_platform(platform)]} {\n" |
2059 | "bind Radiobutton <Enter> {\n" |
2060 | "tkButtonEnter %W\n" |
2061 | "}\n" |
2062 | "bind Radiobutton <1> {\n" |
2063 | "tkButtonDown %W\n" |
2064 | "}\n" |
2065 | "bind Radiobutton <ButtonRelease-1> {\n" |
2066 | "tkButtonUp %W\n" |
2067 | "}\n" |
2068 | "bind Checkbutton <Enter> {\n" |
2069 | "tkButtonEnter %W\n" |
2070 | "}\n" |
2071 | "bind Checkbutton <1> {\n" |
2072 | "tkButtonDown %W\n" |
2073 | "}\n" |
2074 | "bind Checkbutton <ButtonRelease-1> {\n" |
2075 | "tkButtonUp %W\n" |
2076 | "}\n" |
2077 | "}\n" |
2078 | "if {[string match \"windows\" $tcl_platform(platform)]} {\n" |
2079 | "bind Checkbutton <equal> {\n" |
2080 | "tkCheckRadioInvoke %W select\n" |
2081 | "}\n" |
2082 | "bind Checkbutton <plus> {\n" |
2083 | "tkCheckRadioInvoke %W select\n" |
2084 | "}\n" |
2085 | "bind Checkbutton <minus> {\n" |
2086 | "tkCheckRadioInvoke %W deselect\n" |
2087 | "}\n" |
2088 | "bind Checkbutton <1> {\n" |
2089 | "tkCheckRadioDown %W\n" |
2090 | "}\n" |
2091 | "bind Checkbutton <ButtonRelease-1> {\n" |
2092 | "tkButtonUp %W\n" |
2093 | "}\n" |
2094 | "bind Checkbutton <Enter> {\n" |
2095 | "tkCheckRadioEnter %W\n" |
2096 | "}\n" |
2097 | "bind Radiobutton <1> {\n" |
2098 | "tkCheckRadioDown %W\n" |
2099 | "}\n" |
2100 | "bind Radiobutton <ButtonRelease-1> {\n" |
2101 | "tkButtonUp %W\n" |
2102 | "}\n" |
2103 | "bind Radiobutton <Enter> {\n" |
2104 | "tkCheckRadioEnter %W\n" |
2105 | "}\n" |
2106 | "}\n" |
2107 | "if {[string match \"unix\" $tcl_platform(platform)]} {\n" |
2108 | "bind Checkbutton <Return> {\n" |
2109 | "if {!$tk_strictMotif} {\n" |
2110 | "tkCheckRadioInvoke %W\n" |
2111 | "}\n" |
2112 | "}\n" |
2113 | "bind Radiobutton <Return> {\n" |
2114 | "if {!$tk_strictMotif} {\n" |
2115 | "tkCheckRadioInvoke %W\n" |
2116 | "}\n" |
2117 | "}\n" |
2118 | "bind Checkbutton <1> {\n" |
2119 | "tkCheckRadioInvoke %W\n" |
2120 | "}\n" |
2121 | "bind Radiobutton <1> {\n" |
2122 | "tkCheckRadioInvoke %W\n" |
2123 | "}\n" |
2124 | "bind Checkbutton <Enter> {\n" |
2125 | "tkButtonEnter %W\n" |
2126 | "}\n" |
2127 | "bind Radiobutton <Enter> {\n" |
2128 | "tkButtonEnter %W\n" |
2129 | "}\n" |
2130 | "}\n" |
2131 | "bind Button <space> {\n" |
2132 | "tkButtonInvoke %W\n" |
2133 | "}\n" |
2134 | "bind Checkbutton <space> {\n" |
2135 | "tkCheckRadioInvoke %W\n" |
2136 | "}\n" |
2137 | "bind Radiobutton <space> {\n" |
2138 | "tkCheckRadioInvoke %W\n" |
2139 | "}\n" |
2140 | "bind Button <FocusIn> {}\n" |
2141 | "bind Button <Enter> {\n" |
2142 | "tkButtonEnter %W\n" |
2143 | "}\n" |
2144 | "bind Button <Leave> {\n" |
2145 | "tkButtonLeave %W\n" |
2146 | "}\n" |
2147 | "bind Button <1> {\n" |
2148 | "tkButtonDown %W\n" |
2149 | "}\n" |
2150 | "bind Button <ButtonRelease-1> {\n" |
2151 | "tkButtonUp %W\n" |
2152 | "}\n" |
2153 | "bind Checkbutton <FocusIn> {}\n" |
2154 | "bind Checkbutton <Leave> {\n" |
2155 | "tkButtonLeave %W\n" |
2156 | "}\n" |
2157 | "bind Radiobutton <FocusIn> {}\n" |
2158 | "bind Radiobutton <Leave> {\n" |
2159 | "tkButtonLeave %W\n" |
2160 | "}\n" |
2161 | "if {[string match \"windows\" $tcl_platform(platform)]} {\n" |
2162 | "proc tkButtonEnter w {\n" |
2163 | "global tkPriv\n" |
2164 | "if {[string compare [$w cget -state] \"disabled\"] \\\n" |
2165 | "\011 && [string equal $tkPriv(buttonWindow) $w]} {\n" |
2166 | "$w configure -state active -relief sunken\n" |
2167 | "}\n" |
2168 | "set tkPriv(window) $w\n" |
2169 | "}\n" |
2170 | "proc tkButtonLeave w {\n" |
2171 | "global tkPriv\n" |
2172 | "if {[string compare [$w cget -state] \"disabled\"]} {\n" |
2173 | "$w configure -state normal\n" |
2174 | "}\n" |
2175 | "if {[string equal $tkPriv(buttonWindow) $w]} {\n" |
2176 | "$w configure -relief $tkPriv(relief)\n" |
2177 | "}\n" |
2178 | "set tkPriv(window) \"\"\n" |
2179 | "}\n" |
2180 | "proc tkCheckRadioEnter w {\n" |
2181 | "global tkPriv\n" |
2182 | "if {[string compare [$w cget -state] \"disabled\"] \\\n" |
2183 | "\011 && [string equal $tkPriv(buttonWindow) $w]} {\n" |
2184 | "$w configure -state active\n" |
2185 | "}\n" |
2186 | "set tkPriv(window) $w\n" |
2187 | "}\n" |
2188 | "proc tkButtonDown w {\n" |
2189 | "global tkPriv\n" |
2190 | "set tkPriv(relief) [$w cget -relief]\n" |
2191 | "if {[string compare [$w cget -state] \"disabled\"]} {\n" |
2192 | "set tkPriv(buttonWindow) $w\n" |
2193 | "$w configure -relief sunken -state active\n" |
2194 | "}\n" |
2195 | "}\n" |
2196 | "proc tkCheckRadioDown w {\n" |
2197 | "global tkPriv\n" |
2198 | "set tkPriv(relief) [$w cget -relief]\n" |
2199 | "if {[string compare [$w cget -state] \"disabled\"]} {\n" |
2200 | "set tkPriv(buttonWindow) $w\n" |
2201 | "$w configure -state active\n" |
2202 | "}\n" |
2203 | "}\n" |
2204 | "proc tkButtonUp w {\n" |
2205 | "global tkPriv\n" |
2206 | "if {[string equal $tkPriv(buttonWindow) $w]} {\n" |
2207 | "set tkPriv(buttonWindow) \"\"\n" |
2208 | "$w configure -relief $tkPriv(relief)\n" |
2209 | "if {[string equal $tkPriv(window) $w]\n" |
2210 | "&& [string compare [$w cget -state] \"disabled\"]} {\n" |
2211 | "$w configure -state normal\n" |
2212 | "uplevel #0 [list $w invoke]\n" |
2213 | "}\n" |
2214 | "}\n" |
2215 | "}\n" |
2216 | "}\n" |
2217 | "if {[string match \"unix\" $tcl_platform(platform)]} {\n" |
2218 | "proc tkButtonEnter {w} {\n" |
2219 | "global tkPriv\n" |
2220 | "if {[string compare [$w cget -state] \"disabled\"]} {\n" |
2221 | "$w configure -state active\n" |
2222 | "if {[string equal $tkPriv(buttonWindow) $w]} {\n" |
2223 | "$w configure -state active -relief sunken\n" |
2224 | "}\n" |
2225 | "}\n" |
2226 | "set tkPriv(window) $w\n" |
2227 | "}\n" |
2228 | "proc tkButtonLeave w {\n" |
2229 | "global tkPriv\n" |
2230 | "if {[string compare [$w cget -state] \"disabled\"]} {\n" |
2231 | "$w configure -state normal\n" |
2232 | "}\n" |
2233 | "if {[string equal $tkPriv(buttonWindow) $w]} {\n" |
2234 | "$w configure -relief $tkPriv(relief)\n" |
2235 | "}\n" |
2236 | "set tkPriv(window) \"\"\n" |
2237 | "}\n" |
2238 | "proc tkButtonDown w {\n" |
2239 | "global tkPriv\n" |
2240 | "set tkPriv(relief) [$w cget -relief]\n" |
2241 | "if {[string compare [$w cget -state] \"disabled\"]} {\n" |
2242 | "set tkPriv(buttonWindow) $w\n" |
2243 | "$w configure -relief sunken\n" |
2244 | "}\n" |
2245 | "}\n" |
2246 | "proc tkButtonUp w {\n" |
2247 | "global tkPriv\n" |
2248 | "if {[string equal $w $tkPriv(buttonWindow)]} {\n" |
2249 | "set tkPriv(buttonWindow) \"\"\n" |
2250 | "$w configure -relief $tkPriv(relief)\n" |
2251 | "if {[string equal $w $tkPriv(window)] \\\n" |
2252 | "\011\011&& [string compare [$w cget -state] \"disabled\"]} {\n" |
2253 | "uplevel #0 [list $w invoke]\n" |
2254 | "}\n" |
2255 | "}\n" |
2256 | "}\n" |
2257 | "}\n" |
2258 | "if {[string match \"macintosh\" $tcl_platform(platform)]} {\n" |
2259 | "proc tkButtonEnter {w} {\n" |
2260 | "global tkPriv\n" |
2261 | "if {[string compare [$w cget -state] \"disabled\"]} {\n" |
2262 | "if {[string equal $w $tkPriv(buttonWindow)]} {\n" |
2263 | "$w configure -state active\n" |
2264 | "}\n" |
2265 | "}\n" |
2266 | "set tkPriv(window) $w\n" |
2267 | "}\n" |
2268 | "proc tkButtonLeave w {\n" |
2269 | "global tkPriv\n" |
2270 | "if {[string equal $w $tkPriv(buttonWindow)]} {\n" |
2271 | "$w configure -state normal\n" |
2272 | "}\n" |
2273 | "set tkPriv(window) \"\"\n" |
2274 | "}\n" |
2275 | "proc tkButtonDown w {\n" |
2276 | "global tkPriv\n" |
2277 | "if {[string compare [$w cget -state] \"disabled\"]} {\n" |
2278 | "set tkPriv(buttonWindow) $w\n" |
2279 | "$w configure -state active\n" |
2280 | "}\n" |
2281 | "}\n" |
2282 | "proc tkButtonUp w {\n" |
2283 | "global tkPriv\n" |
2284 | "if {[string equal $w $tkPriv(buttonWindow)]} {\n" |
2285 | "$w configure -state normal\n" |
2286 | "set tkPriv(buttonWindow) \"\"\n" |
2287 | "if {[string equal $w $tkPriv(window)]\n" |
2288 | "&& [string compare [$w cget -state] \"disabled\"]} {\n" |
2289 | "uplevel #0 [list $w invoke]\n" |
2290 | "}\n" |
2291 | "}\n" |
2292 | "}\n" |
2293 | "}\n" |
2294 | "proc tkButtonInvoke w {\n" |
2295 | "if {[string compare [$w cget -state] \"disabled\"]} {\n" |
2296 | "set oldRelief [$w cget -relief]\n" |
2297 | "set oldState [$w cget -state]\n" |
2298 | "$w configure -state active -relief sunken\n" |
2299 | "update idletasks\n" |
2300 | "after 100\n" |
2301 | "$w configure -state $oldState -relief $oldRelief\n" |
2302 | "uplevel #0 [list $w invoke]\n" |
2303 | "}\n" |
2304 | "}\n" |
2305 | "proc tkCheckRadioInvoke {w {cmd invoke}} {\n" |
2306 | "if {[string compare [$w cget -state] \"disabled\"]} {\n" |
2307 | "uplevel #0 [list $w $cmd]\n" |
2308 | "}\n" |
2309 | "}\n" |
2310 | ; |
2311 | static char Et_zFile10[] = |
2312 | "proc tkColorDialog {args} {\n" |
2313 | "global tkPriv\n" |
2314 | "set w .__tk__color\n" |
2315 | "upvar #0 $w data\n" |
2316 | "set data(lines,red,start) 0\n" |
2317 | "set data(lines,red,last) -1\n" |
2318 | "set data(lines,green,start) 0\n" |
2319 | "set data(lines,green,last) -1\n" |
2320 | "set data(lines,blue,start) 0\n" |
2321 | "set data(lines,blue,last) -1\n" |
2322 | "set data(NUM_COLORBARS) 8\n" |
2323 | "set data(BARS_WIDTH) 128\n" |
2324 | "set data(PLGN_HEIGHT) 10\n" |
2325 | "set data(PLGN_WIDTH) 10\n" |
2326 | "tkColorDialog_Config $w $args\n" |
2327 | "tkColorDialog_InitValues $w\n" |
2328 | "set sc [winfo screen $data(-parent)]\n" |
2329 | "set winExists [winfo exists $w]\n" |
2330 | "if {!$winExists || [string compare $sc [winfo screen $w]]} {\n" |
2331 | "if {$winExists} {\n" |
2332 | "destroy $w\n" |
2333 | "}\n" |
2334 | "toplevel $w -class tkColorDialog -screen $sc\n" |
2335 | "tkColorDialog_BuildDialog $w\n" |
2336 | "}\n" |
2337 | "wm transient $w $data(-parent)\n" |
2338 | "::tk::PlaceWindow $w widget $data(-parent)\n" |
2339 | "wm title $w $data(-title)\n" |
2340 | "::tk::SetFocusGrab $w $data(okBtn)\n" |
2341 | "vwait tkPriv(selectColor)\n" |
2342 | "::tk::RestoreFocusGrab $w $data(okBtn)\n" |
2343 | "unset data\n" |
2344 | "return $tkPriv(selectColor)\n" |
2345 | "}\n" |
2346 | "proc tkColorDialog_InitValues {w} {\n" |
2347 | "upvar #0 $w data\n" |
2348 | "set data(intensityIncr) [expr {256 / $data(NUM_COLORBARS)}]\n" |
2349 | "set data(colorbarWidth) \\\n" |
2350 | "\011 [expr {$data(BARS_WIDTH) / $data(NUM_COLORBARS)}]\n" |
2351 | "set data(indent) [expr {$data(PLGN_WIDTH) / 2}]\n" |
2352 | "set data(colorPad) 2\n" |
2353 | "set data(selPad) [expr {$data(PLGN_WIDTH) / 2}]\n" |
2354 | "set data(minX) $data(indent)\n" |
2355 | "set data(maxX) [expr {$data(BARS_WIDTH) + $data(indent)-1}]\n" |
2356 | "set data(canvasWidth) [expr {$data(BARS_WIDTH) + $data(PLGN_WIDTH)}]\n" |
2357 | "set data(selection) $data(-initialcolor)\n" |
2358 | "set data(finalColor) $data(-initialcolor)\n" |
2359 | "set rgb [winfo rgb . $data(selection)]\n" |
2360 | "set data(red,intensity) [expr {[lindex $rgb 0]/0x100}]\n" |
2361 | "set data(green,intensity) [expr {[lindex $rgb 1]/0x100}]\n" |
2362 | "set data(blue,intensity) [expr {[lindex $rgb 2]/0x100}]\n" |
2363 | "}\n" |
2364 | "proc tkColorDialog_Config {w argList} {\n" |
2365 | "global tkPriv\n" |
2366 | "upvar #0 $w data\n" |
2367 | "if {[info exists tkPriv(selectColor)] && \\\n" |
2368 | "\011 [string compare $tkPriv(selectColor) \"\"]} {\n" |
2369 | "set defaultColor $tkPriv(selectColor)\n" |
2370 | "} else {\n" |
2371 | "set defaultColor [. cget -background]\n" |
2372 | "}\n" |
2373 | "set specs [list \\\n" |
2374 | "\011 [list -initialcolor \"\" \"\" $defaultColor] \\\n" |
2375 | "\011 [list -parent \"\" \"\" \".\"] \\\n" |
2376 | "\011 [list -title \"\" \"\" \"Color\"] \\\n" |
2377 | "\011 ]\n" |
2378 | "tclParseConfigSpec $w $specs \"\" $argList\n" |
2379 | "if {[string equal $data(-title) \"\"]} {\n" |
2380 | "set data(-title) \" \"\n" |
2381 | "}\n" |
2382 | "if {[catch {winfo rgb . $data(-initialcolor)} err]} {\n" |
2383 | "error $err\n" |
2384 | "}\n" |
2385 | "if {![winfo exists $data(-parent)]} {\n" |
2386 | "error \"bad window path name \\\"$data(-parent)\\\"\"\n" |
2387 | "}\n" |
2388 | "}\n" |
2389 | "proc tkColorDialog_BuildDialog {w} {\n" |
2390 | "upvar #0 $w data\n" |
2391 | "set topFrame [frame $w.top -relief raised -bd 1]\n" |
2392 | "set stripsFrame [frame $topFrame.colorStrip]\n" |
2393 | "foreach c { Red Green Blue } {\n" |
2394 | "set color [string tolower $c]\n" |
2395 | "set f [frame $stripsFrame.$color]\n" |
2396 | "set box [frame $f.box]\n" |
2397 | "label $box.label -text $c: -width 6 -under 0 -anchor ne\n" |
2398 | "entry $box.entry -textvariable [format %s $w]($color,intensity) \\\n" |
2399 | "\011 -width 4\n" |
2400 | "pack $box.label -side left -fill y -padx 2 -pady 3\n" |
2401 | "pack $box.entry -side left -anchor n -pady 0\n" |
2402 | "pack $box -side left -fill both\n" |
2403 | "set height [expr \\\n" |
2404 | "\011 {[winfo reqheight $box.entry] - \\\n" |
2405 | "\011 2*([$box.entry cget -highlightthickness] + [$box.entry cget -bd])}]\n" |
2406 | "canvas $f.color -height $height\\\n" |
2407 | "\011 -width $data(BARS_WIDTH) -relief sunken -bd 2\n" |
2408 | "canvas $f.sel -height $data(PLGN_HEIGHT) \\\n" |
2409 | "\011 -width $data(canvasWidth) -highlightthickness 0\n" |
2410 | "pack $f.color -expand yes -fill both\n" |
2411 | "pack $f.sel -expand yes -fill both\n" |
2412 | "pack $f -side top -fill x -padx 0 -pady 2\n" |
2413 | "set data($color,entry) $box.entry\n" |
2414 | "set data($color,col) $f.color\n" |
2415 | "set data($color,sel) $f.sel\n" |
2416 | "bind $data($color,col) <Configure> \\\n" |
2417 | "\011 [list tkColorDialog_DrawColorScale $w $color 1]\n" |
2418 | "bind $data($color,col) <Enter> \\\n" |
2419 | "\011 [list tkColorDialog_EnterColorBar $w $color]\n" |
2420 | "bind $data($color,col) <Leave> \\\n" |
2421 | "\011 [list tkColorDialog_LeaveColorBar $w $color]\n" |
2422 | "bind $data($color,sel) <Enter> \\\n" |
2423 | "\011 [list tkColorDialog_EnterColorBar $w $color]\n" |
2424 | "bind $data($color,sel) <Leave> \\\n" |
2425 | "\011 [list tkColorDialog_LeaveColorBar $w $color]\n" |
2426 | "bind $box.entry <Return> [list tkColorDialog_HandleRGBEntry $w]\n" |
2427 | "}\n" |
2428 | "pack $stripsFrame -side left -fill both -padx 4 -pady 10\n" |
2429 | "set selFrame [frame $topFrame.sel]\n" |
2430 | "set lab [label $selFrame.lab -text \"Selection:\" -under 0 -anchor sw]\n" |
2431 | "set ent [entry $selFrame.ent -textvariable [format %s $w](selection) \\\n" |
2432 | "\011-width 16]\n" |
2433 | "set f1 [frame $selFrame.f1 -relief sunken -bd 2]\n" |
2434 | "set data(finalCanvas) [frame $f1.demo -bd 0 -width 100 -height 70]\n" |
2435 | "pack $lab $ent -side top -fill x -padx 4 -pady 2\n" |
2436 | "pack $f1 -expand yes -anchor nw -fill both -padx 6 -pady 10\n" |
2437 | "pack $data(finalCanvas) -expand yes -fill both\n" |
2438 | "bind $ent <Return> [list tkColorDialog_HandleSelEntry $w]\n" |
2439 | "pack $selFrame -side left -fill none -anchor nw\n" |
2440 | "pack $topFrame -side top -expand yes -fill both -anchor nw\n" |
2441 | "set botFrame [frame $w.bot -relief raised -bd 1]\n" |
2442 | "button $botFrame.ok -text OK -width 8 -under 0 \\\n" |
2443 | "\011-command [list tkColorDialog_OkCmd $w]\n" |
2444 | "button $botFrame.cancel -text Cancel -width 8 -under 0 \\\n" |
2445 | "\011-command [list tkColorDialog_CancelCmd $w]\n" |
2446 | "set data(okBtn) $botFrame.ok\n" |
2447 | "set data(cancelBtn) $botFrame.cancel\n" |
2448 | "pack $botFrame.ok $botFrame.cancel \\\n" |
2449 | "\011-padx 10 -pady 10 -expand yes -side left\n" |
2450 | "pack $botFrame -side bottom -fill x\n" |
2451 | "bind $w <Alt-r> [list focus $data(red,entry)]\n" |
2452 | "bind $w <Alt-g> [list focus $data(green,entry)]\n" |
2453 | "bind $w <Alt-b> [list focus $data(blue,entry)]\n" |
2454 | "bind $w <Alt-s> [list focus $ent]\n" |
2455 | "bind $w <KeyPress-Escape> [list tkButtonInvoke $data(cancelBtn)]\n" |
2456 | "bind $w <Alt-c> [list tkButtonInvoke $data(cancelBtn)]\n" |
2457 | "bind $w <Alt-o> [list tkButtonInvoke $data(okBtn)]\n" |
2458 | "wm protocol $w WM_DELETE_WINDOW [list tkColorDialog_CancelCmd $w]\n" |
2459 | "}\n" |
2460 | "proc tkColorDialog_SetRGBValue {w color} {\n" |
2461 | "upvar #0 $w data \n" |
2462 | "set data(red,intensity) [lindex $color 0]\n" |
2463 | "set data(green,intensity) [lindex $color 1]\n" |
2464 | "set data(blue,intensity) [lindex $color 2]\n" |
2465 | "tkColorDialog_RedrawColorBars $w all\n" |
2466 | "foreach color { red green blue } {\n" |
2467 | "set x [tkColorDialog_RgbToX $w $data($color,intensity)]\n" |
2468 | "tkColorDialog_MoveSelector $w $data($color,sel) $color $x 0\n" |
2469 | "}\n" |
2470 | "}\n" |
2471 | "proc tkColorDialog_XToRgb {w x} {\n" |
2472 | "upvar #0 $w data\n" |
2473 | "return [expr {($x * $data(intensityIncr))/ $data(colorbarWidth)}]\n" |
2474 | "}\n" |
2475 | "proc tkColorDialog_RgbToX {w color} {\n" |
2476 | "upvar #0 $w data\n" |
2477 | "return [expr {($color * $data(colorbarWidth)/ $data(intensityIncr))}]\n" |
2478 | "}\n" |
2479 | "proc tkColorDialog_DrawColorScale {w c {create 0}} {\n" |
2480 | "global lines\n" |
2481 | "upvar #0 $w data\n" |
2482 | "set col $data($c,col)\n" |
2483 | "set sel $data($c,sel)\n" |
2484 | "if {$create} {\n" |
2485 | "if { $data(lines,$c,last) > $data(lines,$c,start)} {\n" |
2486 | "for {set i $data(lines,$c,start)} \\\n" |
2487 | "\011\011{$i <= $data(lines,$c,last)} { incr i} {\n" |
2488 | "$sel delete $i\n" |
2489 | "}\n" |
2490 | "}\n" |
2491 | "if {[info exists data($c,index)]} {\n" |
2492 | "$sel delete $data($c,index)\n" |
2493 | "}\n" |
2494 | "tkColorDialog_CreateSelector $w $sel $c\n" |
2495 | "$sel bind $data($c,index) <ButtonPress-1> \\\n" |
2496 | "\011\011[list tkColorDialog_StartMove $w $sel $c %x $data(selPad) 1]\n" |
2497 | "$sel bind $data($c,index) <B1-Motion> \\\n" |
2498 | "\011\011[list tkColorDialog_MoveSelector $w $sel $c %x $data(selPad)]\n" |
2499 | "$sel bind $data($c,index) <ButtonRelease-1> \\\n" |
2500 | "\011\011[list tkColorDialog_ReleaseMouse $w $sel $c %x $data(selPad)]\n" |
2501 | "set height [winfo height $col]\n" |
2502 | "set data($c,clickRegion) [$sel create rectangle 0 0 \\\n" |
2503 | "\011\011$data(canvasWidth) $height -fill {} -outline {}]\n" |
2504 | "bind $col <ButtonPress-1> \\\n" |
2505 | "\011\011[list tkColorDialog_StartMove $w $sel $c %x $data(colorPad)]\n" |
2506 | "bind $col <B1-Motion> \\\n" |
2507 | "\011\011[list tkColorDialog_MoveSelector $w $sel $c %x $data(colorPad)]\n" |
2508 | "bind $col <ButtonRelease-1> \\\n" |
2509 | "\011\011[list tkColorDialog_ReleaseMouse $w $sel $c %x $data(colorPad)]\n" |
2510 | "$sel bind $data($c,clickRegion) <ButtonPress-1> \\\n" |
2511 | "\011\011[list tkColorDialog_StartMove $w $sel $c %x $data(selPad)]\n" |
2512 | "$sel bind $data($c,clickRegion) <B1-Motion> \\\n" |
2513 | "\011\011[list tkColorDialog_MoveSelector $w $sel $c %x $data(selPad)]\n" |
2514 | "$sel bind $data($c,clickRegion) <ButtonRelease-1> \\\n" |
2515 | "\011\011[list tkColorDialog_ReleaseMouse $w $sel $c %x $data(selPad)]\n" |
2516 | "} else {\n" |
2517 | "set l $data(lines,$c,start)\n" |
2518 | "}\n" |
2519 | "set highlightW [expr {[$col cget -highlightthickness] + [$col cget -bd]}]\n" |
2520 | "for {set i 0} { $i < $data(NUM_COLORBARS)} { incr i} {\n" |
2521 | "set intensity [expr {$i * $data(intensityIncr)}]\n" |
2522 | "set startx [expr {$i * $data(colorbarWidth) + $highlightW}]\n" |
2523 | "if {[string equal $c \"red\"]} {\n" |
2524 | "set color [format \"#%02x%02x%02x\" \\\n" |
2525 | "\011\011\011 $intensity \\\n" |
2526 | "\011\011\011 $data(green,intensity) \\\n" |
2527 | "\011\011\011 $data(blue,intensity)]\n" |
2528 | "} elseif {[string equal $c \"green\"]} {\n" |
2529 | "set color [format \"#%02x%02x%02x\" \\\n" |
2530 | "\011\011\011 $data(red,intensity) \\\n" |
2531 | "\011\011\011 $intensity \\\n" |
2532 | "\011\011\011 $data(blue,intensity)]\n" |
2533 | "} else {\n" |
2534 | "set color [format \"#%02x%02x%02x\" \\\n" |
2535 | "\011\011\011 $data(red,intensity) \\\n" |
2536 | "\011\011\011 $data(green,intensity) \\\n" |
2537 | "\011\011\011 $intensity]\n" |
2538 | "}\n" |
2539 | "if {$create} {\n" |
2540 | "set index [$col create rect $startx $highlightW \\\n" |
2541 | "\011\011 [expr {$startx +$data(colorbarWidth)}] \\\n" |
2542 | "\011\011 [expr {[winfo height $col] + $highlightW}]\\\n" |
2543 | "\011 -fill $color -outline $color]\n" |
2544 | "} else {\n" |
2545 | "$col itemconfigure $l -fill $color -outline $color\n" |
2546 | "incr l\n" |
2547 | "}\n" |
2548 | "}\n" |
2549 | "$sel raise $data($c,index)\n" |
2550 | "if {$create} {\n" |
2551 | "set data(lines,$c,last) $index\n" |
2552 | "set data(lines,$c,start) [expr {$index - $data(NUM_COLORBARS) + 1}]\n" |
2553 | "}\n" |
2554 | "tkColorDialog_RedrawFinalColor $w\n" |
2555 | "}\n" |
2556 | "proc tkColorDialog_CreateSelector {w sel c } {\n" |
2557 | "upvar #0 $w data\n" |
2558 | "set data($c,index) [$sel create polygon \\\n" |
2559 | "\0110 $data(PLGN_HEIGHT) \\\n" |
2560 | "\011$data(PLGN_WIDTH) $data(PLGN_HEIGHT) \\\n" |
2561 | "\011$data(indent) 0]\n" |
2562 | "set data($c,x) [tkColorDialog_RgbToX $w $data($c,intensity)]\n" |
2563 | "$sel move $data($c,index) $data($c,x) 0\n" |
2564 | "}\n" |
2565 | "proc tkColorDialog_RedrawFinalColor {w} {\n" |
2566 | "upvar #0 $w data\n" |
2567 | "set color [format \"#%02x%02x%02x\" $data(red,intensity) \\\n" |
2568 | "\011$data(green,intensity) $data(blue,intensity)]\n" |
2569 | "$data(finalCanvas) configure -bg $color\n" |
2570 | "set data(finalColor) $color\n" |
2571 | "set data(selection) $color\n" |
2572 | "set data(finalRGB) [list \\\n" |
2573 | "\011 $data(red,intensity) \\\n" |
2574 | "\011 $data(green,intensity) \\\n" |
2575 | "\011 $data(blue,intensity)]\n" |
2576 | "}\n" |
2577 | "proc tkColorDialog_RedrawColorBars {w colorChanged} {\n" |
2578 | "upvar #0 $w data\n" |
2579 | "switch $colorChanged {\n" |
2580 | "red { \n" |
2581 | "tkColorDialog_DrawColorScale $w green\n" |
2582 | "tkColorDialog_DrawColorScale $w blue\n" |
2583 | "}\n" |
2584 | "green {\n" |
2585 | "tkColorDialog_DrawColorScale $w red\n" |
2586 | "tkColorDialog_DrawColorScale $w blue\n" |
2587 | "}\n" |
2588 | "blue {\n" |
2589 | "tkColorDialog_DrawColorScale $w red\n" |
2590 | "tkColorDialog_DrawColorScale $w green\n" |
2591 | "}\n" |
2592 | "default {\n" |
2593 | "tkColorDialog_DrawColorScale $w red\n" |
2594 | "tkColorDialog_DrawColorScale $w green\n" |
2595 | "tkColorDialog_DrawColorScale $w blue\n" |
2596 | "}\n" |
2597 | "}\n" |
2598 | "tkColorDialog_RedrawFinalColor $w\n" |
2599 | "}\n" |
2600 | "proc tkColorDialog_StartMove {w sel color x delta {dontMove 0}} {\n" |
2601 | "upvar #0 $w data\n" |
2602 | "if {!$dontMove} {\n" |
2603 | "tkColorDialog_MoveSelector $w $sel $color $x $delta\n" |
2604 | "}\n" |
2605 | "}\n" |
2606 | "proc tkColorDialog_MoveSelector {w sel color x delta} {\n" |
2607 | "upvar #0 $w data\n" |
2608 | "incr x -$delta\n" |
2609 | "if { $x < 0 } {\n" |
2610 | "set x 0\n" |
2611 | "} elseif { $x >= $data(BARS_WIDTH)} {\n" |
2612 | "set x [expr {$data(BARS_WIDTH) - 1}]\n" |
2613 | "}\n" |
2614 | "set diff [expr {$x - $data($color,x)}]\n" |
2615 | "$sel move $data($color,index) $diff 0\n" |
2616 | "set data($color,x) [expr {$data($color,x) + $diff}]\n" |
2617 | "return $x\n" |
2618 | "}\n" |
2619 | "proc tkColorDialog_ReleaseMouse {w sel color x delta} {\n" |
2620 | "upvar #0 $w data \n" |
2621 | "set x [tkColorDialog_MoveSelector $w $sel $color $x $delta]\n" |
2622 | "set data($color,intensity) [tkColorDialog_XToRgb $w $x]\n" |
2623 | "tkColorDialog_RedrawColorBars $w $color\n" |
2624 | "}\n" |
2625 | "proc tkColorDialog_ResizeColorBars {w} {\n" |
2626 | "upvar #0 $w data\n" |
2627 | "if { ($data(BARS_WIDTH) < $data(NUM_COLORBARS)) || \n" |
2628 | "(($data(BARS_WIDTH) % $data(NUM_COLORBARS)) != 0)} {\n" |
2629 | "set data(BARS_WIDTH) $data(NUM_COLORBARS)\n" |
2630 | "}\n" |
2631 | "tkColorDialog_InitValues $w\n" |
2632 | "foreach color { red green blue } {\n" |
2633 | "$data($color,col) configure -width $data(canvasWidth)\n" |
2634 | "tkColorDialog_DrawColorScale $w $color 1\n" |
2635 | "}\n" |
2636 | "}\n" |
2637 | "proc tkColorDialog_HandleSelEntry {w} {\n" |
2638 | "upvar #0 $w data\n" |
2639 | "set text [string trim $data(selection)]\n" |
2640 | "if {[catch {set color [winfo rgb . $text]} ]} {\n" |
2641 | "set data(selection) $data(finalColor)\n" |
2642 | "return\n" |
2643 | "}\n" |
2644 | "set R [expr {[lindex $color 0]/0x100}]\n" |
2645 | "set G [expr {[lindex $color 1]/0x100}]\n" |
2646 | "set B [expr {[lindex $color 2]/0x100}]\n" |
2647 | "tkColorDialog_SetRGBValue $w \"$R $G $B\"\n" |
2648 | "set data(selection) $text\n" |
2649 | "}\n" |
2650 | "proc tkColorDialog_HandleRGBEntry {w} {\n" |
2651 | "upvar #0 $w data\n" |
2652 | "foreach c {red green blue} {\n" |
2653 | "if {[catch {\n" |
2654 | "set data($c,intensity) [expr {int($data($c,intensity))}]\n" |
2655 | "}]} {\n" |
2656 | "set data($c,intensity) 0\n" |
2657 | "}\n" |
2658 | "if {$data($c,intensity) < 0} {\n" |
2659 | "set data($c,intensity) 0\n" |
2660 | "}\n" |
2661 | "if {$data($c,intensity) > 255} {\n" |
2662 | "set data($c,intensity) 255\n" |
2663 | "}\n" |
2664 | "}\n" |
2665 | "tkColorDialog_SetRGBValue $w \"$data(red,intensity) $data(green,intensity) \\\n" |
2666 | "\011$data(blue,intensity)\"\n" |
2667 | "} \n" |
2668 | "proc tkColorDialog_EnterColorBar {w color} {\n" |
2669 | "upvar #0 $w data\n" |
2670 | "$data($color,sel) itemconfig $data($color,index) -fill red\n" |
2671 | "}\n" |
2672 | "proc tkColorDialog_LeaveColorBar {w color} {\n" |
2673 | "upvar #0 $w data\n" |
2674 | "$data($color,sel) itemconfig $data($color,index) -fill black\n" |
2675 | "}\n" |
2676 | "proc tkColorDialog_OkCmd {w} {\n" |
2677 | "global tkPriv\n" |
2678 | "upvar #0 $w data\n" |
2679 | "set tkPriv(selectColor) $data(finalColor)\n" |
2680 | "}\n" |
2681 | "proc tkColorDialog_CancelCmd {w} {\n" |
2682 | "global tkPriv\n" |
2683 | "set tkPriv(selectColor) \"\"\n" |
2684 | "}\n" |
2685 | ; |
2686 | static char Et_zFile11[] = |
2687 | "proc tclParseConfigSpec {w specs flags argList} {\n" |
2688 | "upvar #0 $w data\n" |
2689 | "foreach spec $specs {\n" |
2690 | "if {[llength $spec] < 4} {\n" |
2691 | "error \"\\\"spec\\\" should contain 5 or 4 elements\"\n" |
2692 | "}\n" |
2693 | "set cmdsw [lindex $spec 0]\n" |
2694 | "set cmd($cmdsw) \"\"\n" |
2695 | "set rname($cmdsw) [lindex $spec 1]\n" |
2696 | "set rclass($cmdsw) [lindex $spec 2]\n" |
2697 | "set def($cmdsw) [lindex $spec 3]\n" |
2698 | "set verproc($cmdsw) [lindex $spec 4]\n" |
2699 | "}\n" |
2700 | "if {[llength $argList] & 1} {\n" |
2701 | "set cmdsw [lindex $argList end]\n" |
2702 | "if {![info exists cmd($cmdsw)]} {\n" |
2703 | "error \"bad option \\\"$cmdsw\\\": must be [tclListValidFlags cmd]\"\n" |
2704 | "}\n" |
2705 | "error \"value for \\\"$cmdsw\\\" missing\"\n" |
2706 | "}\n" |
2707 | "foreach cmdsw [array names cmd] {\n" |
2708 | "set data($cmdsw) $def($cmdsw)\n" |
2709 | "}\n" |
2710 | "foreach {cmdsw value} $argList {\n" |
2711 | "if {![info exists cmd($cmdsw)]} {\n" |
2712 | "error \"bad option \\\"$cmdsw\\\": must be [tclListValidFlags cmd]\"\n" |
2713 | "}\n" |
2714 | "set data($cmdsw) $value\n" |
2715 | "}\n" |
2716 | "}\n" |
2717 | "proc tclListValidFlags {v} {\n" |
2718 | "upvar $v cmd\n" |
2719 | "set len [llength [array names cmd]]\n" |
2720 | "set i 1\n" |
2721 | "set separator \"\"\n" |
2722 | "set errormsg \"\"\n" |
2723 | "foreach cmdsw [lsort [array names cmd]] {\n" |
2724 | "append errormsg \"$separator$cmdsw\"\n" |
2725 | "incr i\n" |
2726 | "if {$i == $len} {\n" |
2727 | "set separator \", or \"\n" |
2728 | "} else {\n" |
2729 | "set separator \", \"\n" |
2730 | "}\n" |
2731 | "}\n" |
2732 | "return $errormsg\n" |
2733 | "}\n" |
2734 | "proc tkFocusGroup_Create {t} {\n" |
2735 | "global tkPriv\n" |
2736 | "if {[string compare [winfo toplevel $t] $t]} {\n" |
2737 | "error \"$t is not a toplevel window\"\n" |
2738 | "}\n" |
2739 | "if {![info exists tkPriv(fg,$t)]} {\n" |
2740 | "set tkPriv(fg,$t) 1\n" |
2741 | "set tkPriv(focus,$t) \"\"\n" |
2742 | "bind $t <FocusIn> [list tkFocusGroup_In $t %W %d]\n" |
2743 | "bind $t <FocusOut> [list tkFocusGroup_Out $t %W %d]\n" |
2744 | "bind $t <Destroy> [list tkFocusGroup_Destroy $t %W]\n" |
2745 | "}\n" |
2746 | "}\n" |
2747 | "proc tkFocusGroup_BindIn {t w cmd} {\n" |
2748 | "global tkFocusIn tkPriv\n" |
2749 | "if {![info exists tkPriv(fg,$t)]} {\n" |
2750 | "error \"focus group \\\"$t\\\" doesn't exist\"\n" |
2751 | "}\n" |
2752 | "set tkFocusIn($t,$w) $cmd\n" |
2753 | "}\n" |
2754 | "proc tkFocusGroup_BindOut {t w cmd} {\n" |
2755 | "global tkFocusOut tkPriv\n" |
2756 | "if {![info exists tkPriv(fg,$t)]} {\n" |
2757 | "error \"focus group \\\"$t\\\" doesn't exist\"\n" |
2758 | "}\n" |
2759 | "set tkFocusOut($t,$w) $cmd\n" |
2760 | "}\n" |
2761 | "proc tkFocusGroup_Destroy {t w} {\n" |
2762 | "global tkPriv tkFocusIn tkFocusOut\n" |
2763 | "if {[string equal $t $w]} {\n" |
2764 | "unset tkPriv(fg,$t)\n" |
2765 | "unset tkPriv(focus,$t) \n" |
2766 | "foreach name [array names tkFocusIn $t,*] {\n" |
2767 | "unset tkFocusIn($name)\n" |
2768 | "}\n" |
2769 | "foreach name [array names tkFocusOut $t,*] {\n" |
2770 | "unset tkFocusOut($name)\n" |
2771 | "}\n" |
2772 | "} else {\n" |
2773 | "if {[info exists tkPriv(focus,$t)] && \\\n" |
2774 | "\011\011[string equal $tkPriv(focus,$t) $w]} {\n" |
2775 | "set tkPriv(focus,$t) \"\"\n" |
2776 | "}\n" |
2777 | "catch {\n" |
2778 | "unset tkFocusIn($t,$w)\n" |
2779 | "}\n" |
2780 | "catch {\n" |
2781 | "unset tkFocusOut($t,$w)\n" |
2782 | "}\n" |
2783 | "}\n" |
2784 | "}\n" |
2785 | "proc tkFocusGroup_In {t w detail} {\n" |
2786 | "global tkPriv tkFocusIn\n" |
2787 | "if {[string compare $detail NotifyNonlinear] && \\\n" |
2788 | "\011 [string compare $detail NotifyNonlinearVirtual]} {\n" |
2789 | "return\n" |
2790 | "}\n" |
2791 | "if {![info exists tkFocusIn($t,$w)]} {\n" |
2792 | "set tkFocusIn($t,$w) \"\"\n" |
2793 | "return\n" |
2794 | "}\n" |
2795 | "if {![info exists tkPriv(focus,$t)]} {\n" |
2796 | "return\n" |
2797 | "}\n" |
2798 | "if {[string equal $tkPriv(focus,$t) $w]} {\n" |
2799 | "return\n" |
2800 | "} else {\n" |
2801 | "set tkPriv(focus,$t) $w\n" |
2802 | "eval $tkFocusIn($t,$w)\n" |
2803 | "}\n" |
2804 | "}\n" |
2805 | "proc tkFocusGroup_Out {t w detail} {\n" |
2806 | "global tkPriv tkFocusOut\n" |
2807 | "if {[string compare $detail NotifyNonlinear] && \\\n" |
2808 | "\011 [string compare $detail NotifyNonlinearVirtual]} {\n" |
2809 | "return\n" |
2810 | "}\n" |
2811 | "if {![info exists tkPriv(focus,$t)]} {\n" |
2812 | "return\n" |
2813 | "}\n" |
2814 | "if {![info exists tkFocusOut($t,$w)]} {\n" |
2815 | "return\n" |
2816 | "} else {\n" |
2817 | "eval $tkFocusOut($t,$w)\n" |
2818 | "set tkPriv(focus,$t) \"\"\n" |
2819 | "}\n" |
2820 | "}\n" |
2821 | "proc tkFDGetFileTypes {string} {\n" |
2822 | "foreach t $string {\n" |
2823 | "if {[llength $t] < 2 || [llength $t] > 3} {\n" |
2824 | "error \"bad file type \\\"$t\\\", should be \\\"typeName {extension ?extensions ...?} ?{macType ?macTypes ...?}?\\\"\"\n" |
2825 | "}\n" |
2826 | "eval lappend [list fileTypes([lindex $t 0])] [lindex $t 1]\n" |
2827 | "}\n" |
2828 | "set types {}\n" |
2829 | "foreach t $string {\n" |
2830 | "set label [lindex $t 0]\n" |
2831 | "set exts {}\n" |
2832 | "if {[info exists hasDoneType($label)]} {\n" |
2833 | "continue\n" |
2834 | "}\n" |
2835 | "set name \"$label (\"\n" |
2836 | "set sep \"\"\n" |
2837 | "foreach ext $fileTypes($label) {\n" |
2838 | "if {[string equal $ext \"\"]} {\n" |
2839 | "continue\n" |
2840 | "}\n" |
2841 | "regsub {^[.]} $ext \"*.\" ext\n" |
2842 | "if {![info exists hasGotExt($label,$ext)]} {\n" |
2843 | "append name $sep$ext\n" |
2844 | "lappend exts $ext\n" |
2845 | "set hasGotExt($label,$ext) 1\n" |
2846 | "}\n" |
2847 | "set sep ,\n" |
2848 | "}\n" |
2849 | "append name \")\"\n" |
2850 | "lappend types [list $name $exts]\n" |
2851 | "set hasDoneType($label) 1\n" |
2852 | "}\n" |
2853 | "return $types\n" |
2854 | "}\n" |
2855 | ; |
2856 | static char Et_zFile12[] = |
2857 | "proc tkConsoleInit {} {\n" |
2858 | "global tcl_platform\n" |
2859 | "if {![consoleinterp eval {set tcl_interactive}]} {\n" |
2860 | "wm withdraw .\n" |
2861 | "}\n" |
2862 | "if {[string compare $tcl_platform(platform) \"macintosh\"]} {\n" |
2863 | "set mod \"Ctrl\"\n" |
2864 | "} else {\n" |
2865 | "set mod \"Cmd\"\n" |
2866 | "}\n" |
2867 | "menu .menubar\n" |
2868 | ".menubar add cascade -label File -menu .menubar.file -underline 0\n" |
2869 | ".menubar add cascade -label Edit -menu .menubar.edit -underline 0\n" |
2870 | "menu .menubar.file -tearoff 0\n" |
2871 | ".menubar.file add command -label \"Source...\" -underline 0 \\\n" |
2872 | "\011 -command tkConsoleSource\n" |
2873 | ".menubar.file add command -label \"Hide Console\" -underline 0 \\\n" |
2874 | "\011 -command {wm withdraw .}\n" |
2875 | "if {[string compare $tcl_platform(platform) \"macintosh\"]} {\n" |
2876 | ".menubar.file add command -label \"Exit\" -underline 1 -command exit\n" |
2877 | "} else {\n" |
2878 | ".menubar.file add command -label \"Quit\" -command exit -accel Cmd-Q\n" |
2879 | "}\n" |
2880 | "menu .menubar.edit -tearoff 0\n" |
2881 | ".menubar.edit add command -label \"Cut\" -underline 2 \\\n" |
2882 | "\011 -command { event generate .console <<Cut>> } -accel \"$mod+X\"\n" |
2883 | ".menubar.edit add command -label \"Copy\" -underline 0 \\\n" |
2884 | "\011 -command { event generate .console <<Copy>> } -accel \"$mod+C\"\n" |
2885 | ".menubar.edit add command -label \"Paste\" -underline 1 \\\n" |
2886 | "\011 -command { event generate .console <<Paste>> } -accel \"$mod+V\"\n" |
2887 | "if {[string compare $tcl_platform(platform) \"windows\"]} {\n" |
2888 | ".menubar.edit add command -label \"Clear\" -underline 2 \\\n" |
2889 | "\011\011-command { event generate .console <<Clear>> }\n" |
2890 | "} else {\n" |
2891 | ".menubar.edit add command -label \"Delete\" -underline 0 \\\n" |
2892 | "\011\011-command { event generate .console <<Clear>> } -accel \"Del\"\n" |
2893 | ".menubar add cascade -label Help -menu .menubar.help -underline 0\n" |
2894 | "menu .menubar.help -tearoff 0\n" |
2895 | ".menubar.help add command -label \"About...\" -underline 0 \\\n" |
2896 | "\011\011-command tkConsoleAbout\n" |
2897 | "}\n" |
2898 | ". configure -menu .menubar\n" |
2899 | "text .console -yscrollcommand \".sb set\" -setgrid true \n" |
2900 | "scrollbar .sb -command \".console yview\"\n" |
2901 | "pack .sb -side right -fill both\n" |
2902 | "pack .console -fill both -expand 1 -side left\n" |
2903 | "switch -exact $tcl_platform(platform) {\n" |
2904 | "\"macintosh\" {\n" |
2905 | ".console configure -font {Monaco 9 normal} -highlightthickness 0\n" |
2906 | "}\n" |
2907 | "\"windows\" {\n" |
2908 | ".console configure -font systemfixed\n" |
2909 | "}\n" |
2910 | "}\n" |
2911 | "tkConsoleBind .console\n" |
2912 | ".console tag configure stderr -foreground red\n" |
2913 | ".console tag configure stdin -foreground blue\n" |
2914 | "focus .console\n" |
2915 | "wm protocol . WM_DELETE_WINDOW { wm withdraw . }\n" |
2916 | "wm title . \"" BUILD_CONFIG_STATIC_WISH_ALIAS " v" BUILD_CONFIG_RELEASE_VERSION "\"\n" |
2917 | "flush stdout\n" |
2918 | ".console mark set output [.console index \"end - 1 char\"]\n" |
2919 | "tkTextSetCursor .console end\n" |
2920 | ".console mark set promptEnd insert\n" |
2921 | ".console mark gravity promptEnd left\n" |
2922 | "}\n" |
2923 | "proc tkConsoleSource {} {\n" |
2924 | "set filename [tk_getOpenFile -defaultextension .tcl -parent . \\\n" |
2925 | "\011\011 -title \"Select a file to source\" \\\n" |
2926 | "\011\011 -filetypes {{\"Tcl Scripts\" .tcl} {\"All Files\" *}}]\n" |
2927 | "if {[string compare $filename \"\"]} {\n" |
2928 | "set cmd [list source $filename]\n" |
2929 | "if {[catch {consoleinterp eval $cmd} result]} {\n" |
2930 | "tkConsoleOutput stderr \"$result\\n\"\n" |
2931 | "}\n" |
2932 | "}\n" |
2933 | "}\n" |
2934 | "proc tkConsoleInvoke {args} {\n" |
2935 | "set ranges [.console tag ranges input]\n" |
2936 | "set cmd \"\"\n" |
2937 | "if {[llength $ranges]} {\n" |
2938 | "set pos 0\n" |
2939 | "while {[string compare [lindex $ranges $pos] \"\"]} {\n" |
2940 | "set start [lindex $ranges $pos]\n" |
2941 | "set end [lindex $ranges [incr pos]]\n" |
2942 | "append cmd [.console get $start $end]\n" |
2943 | "incr pos\n" |
2944 | "}\n" |
2945 | "}\n" |
2946 | "if {[string equal $cmd \"\"]} {\n" |
2947 | "tkConsolePrompt\n" |
2948 | "} elseif {[info complete $cmd]} {\n" |
2949 | ".console mark set output end\n" |
2950 | ".console tag delete input\n" |
2951 | "set result [consoleinterp record $cmd]\n" |
2952 | "if {[string compare $result \"\"]} {\n" |
2953 | "puts $result\n" |
2954 | "}\n" |
2955 | "tkConsoleHistory reset\n" |
2956 | "tkConsolePrompt\n" |
2957 | "} else {\n" |
2958 | "tkConsolePrompt partial\n" |
2959 | "}\n" |
2960 | ".console yview -pickplace insert\n" |
2961 | "}\n" |
2962 | "set histNum 1\n" |
2963 | "proc tkConsoleHistory {cmd} {\n" |
2964 | "global histNum\n" |
2965 | "switch $cmd {\n" |
2966 | "prev {\n" |
2967 | "incr histNum -1\n" |
2968 | "if {$histNum == 0} {\n" |
2969 | "set cmd {history event [expr {[history nextid] -1}]}\n" |
2970 | "} else {\n" |
2971 | "set cmd \"history event $histNum\"\n" |
2972 | "}\n" |
2973 | "if {[catch {consoleinterp eval $cmd} cmd]} {\n" |
2974 | "incr histNum\n" |
2975 | "return\n" |
2976 | "}\n" |
2977 | ".console delete promptEnd end\n" |
2978 | ".console insert promptEnd $cmd {input stdin}\n" |
2979 | "}\n" |
2980 | "next {\n" |
2981 | "incr histNum\n" |
2982 | "if {$histNum == 0} {\n" |
2983 | "set cmd {history event [expr {[history nextid] -1}]}\n" |
2984 | "} elseif {$histNum > 0} {\n" |
2985 | "set cmd \"\"\n" |
2986 | "set histNum 1\n" |
2987 | "} else {\n" |
2988 | "set cmd \"history event $histNum\"\n" |
2989 | "}\n" |
2990 | "if {[string compare $cmd \"\"]} {\n" |
2991 | "catch {consoleinterp eval $cmd} cmd\n" |
2992 | "}\n" |
2993 | ".console delete promptEnd end\n" |
2994 | ".console insert promptEnd $cmd {input stdin}\n" |
2995 | "}\n" |
2996 | "reset {\n" |
2997 | "set histNum 1\n" |
2998 | "}\n" |
2999 | "}\n" |
3000 | "}\n" |
3001 | "proc tkConsolePrompt {{partial normal}} {\n" |
3002 | "if {[string equal $partial \"normal\"]} {\n" |
3003 | "set temp [.console index \"end - 1 char\"]\n" |
3004 | ".console mark set output end\n" |
3005 | "if {[consoleinterp eval \"info exists tcl_prompt1\"]} {\n" |
3006 | "consoleinterp eval \"eval \\[set tcl_prompt1\\]\"\n" |
3007 | "} else {\n" |
3008 | "puts -nonewline \"% \"\n" |
3009 | "}\n" |
3010 | "} else {\n" |
3011 | "set temp [.console index output]\n" |
3012 | ".console mark set output end\n" |
3013 | "if {[consoleinterp eval \"info exists tcl_prompt2\"]} {\n" |
3014 | "consoleinterp eval \"eval \\[set tcl_prompt2\\]\"\n" |
3015 | "} else {\n" |
3016 | "puts -nonewline \"> \"\n" |
3017 | "}\n" |
3018 | "}\n" |
3019 | "flush stdout\n" |
3020 | ".console mark set output $temp\n" |
3021 | "tkTextSetCursor .console end\n" |
3022 | ".console mark set promptEnd insert\n" |
3023 | ".console mark gravity promptEnd left\n" |
3024 | "}\n" |
3025 | "proc tkConsoleBind {win} {\n" |
3026 | "bindtags $win \"$win Text . all\"\n" |
3027 | "bind $win <Alt-KeyPress> {# nothing }\n" |
3028 | "bind $win <Meta-KeyPress> {# nothing}\n" |
3029 | "bind $win <Control-KeyPress> {# nothing}\n" |
3030 | "bind $win <Escape> {# nothing}\n" |
3031 | "bind $win <KP_Enter> {# nothing}\n" |
3032 | "bind $win <Tab> {\n" |
3033 | "tkConsoleInsert %W \\t\n" |
3034 | "focus %W\n" |
3035 | "break\n" |
3036 | "}\n" |
3037 | "bind $win <Return> {\n" |
3038 | "%W mark set insert {end - 1c}\n" |
3039 | "tkConsoleInsert %W \"\\n\"\n" |
3040 | "tkConsoleInvoke\n" |
3041 | "break\n" |
3042 | "}\n" |
3043 | "bind $win <Delete> {\n" |
3044 | "if {[string compare [%W tag nextrange sel 1.0 end] \"\"]} {\n" |
3045 | "%W tag remove sel sel.first promptEnd\n" |
3046 | "} elseif {[%W compare insert < promptEnd]} {\n" |
3047 | "break\n" |
3048 | "}\n" |
3049 | "}\n" |
3050 | "bind $win <BackSpace> {\n" |
3051 | "if {[string compare [%W tag nextrange sel 1.0 end] \"\"]} {\n" |
3052 | "%W tag remove sel sel.first promptEnd\n" |
3053 | "} elseif {[%W compare insert <= promptEnd]} {\n" |
3054 | "break\n" |
3055 | "}\n" |
3056 | "}\n" |
3057 | "foreach left {Control-a Home} {\n" |
3058 | "bind $win <$left> {\n" |
3059 | "if {[%W compare insert < promptEnd]} {\n" |
3060 | "tkTextSetCursor %W {insert linestart}\n" |
3061 | "} else {\n" |
3062 | "tkTextSetCursor %W promptEnd\n" |
3063 | "}\n" |
3064 | "break\n" |
3065 | "}\n" |
3066 | "}\n" |
3067 | "foreach right {Control-e End} {\n" |
3068 | "bind $win <$right> {\n" |
3069 | "tkTextSetCursor %W {insert lineend}\n" |
3070 | "break\n" |
3071 | "}\n" |
3072 | "}\n" |
3073 | "bind $win <Control-d> {\n" |
3074 | "if {[%W compare insert < promptEnd]} {\n" |
3075 | "break\n" |
3076 | "}\n" |
3077 | "}\n" |
3078 | "bind $win <Control-k> {\n" |
3079 | "if {[%W compare insert < promptEnd]} {\n" |
3080 | "%W mark set insert promptEnd\n" |
3081 | "}\n" |
3082 | "}\n" |
3083 | "bind $win <Control-t> {\n" |
3084 | "if {[%W compare insert < promptEnd]} {\n" |
3085 | "break\n" |
3086 | "}\n" |
3087 | "}\n" |
3088 | "bind $win <Meta-d> {\n" |
3089 | "if {[%W compare insert < promptEnd]} {\n" |
3090 | "break\n" |
3091 | "}\n" |
3092 | "}\n" |
3093 | "bind $win <Meta-BackSpace> {\n" |
3094 | "if {[%W compare insert <= promptEnd]} {\n" |
3095 | "break\n" |
3096 | "}\n" |
3097 | "}\n" |
3098 | "bind $win <Control-h> {\n" |
3099 | "if {[%W compare insert <= promptEnd]} {\n" |
3100 | "break\n" |
3101 | "}\n" |
3102 | "}\n" |
3103 | "foreach prev {Control-p Up} {\n" |
3104 | "bind $win <$prev> {\n" |
3105 | "tkConsoleHistory prev\n" |
3106 | "break\n" |
3107 | "}\n" |
3108 | "}\n" |
3109 | "foreach prev {Control-n Down} {\n" |
3110 | "bind $win <$prev> {\n" |
3111 | "tkConsoleHistory next\n" |
3112 | "break\n" |
3113 | "}\n" |
3114 | "}\n" |
3115 | "bind $win <Insert> {\n" |
3116 | "catch {tkConsoleInsert %W [selection get -displayof %W]}\n" |
3117 | "break\n" |
3118 | "}\n" |
3119 | "bind $win <KeyPress> {\n" |
3120 | "tkConsoleInsert %W %A\n" |
3121 | "break\n" |
3122 | "}\n" |
3123 | "foreach left {Control-b Left} {\n" |
3124 | "bind $win <$left> {\n" |
3125 | "if {[%W compare insert == promptEnd]} {\n" |
3126 | "break\n" |
3127 | "}\n" |
3128 | "tkTextSetCursor %W insert-1c\n" |
3129 | "break\n" |
3130 | "}\n" |
3131 | "}\n" |
3132 | "foreach right {Control-f Right} {\n" |
3133 | "bind $win <$right> {\n" |
3134 | "tkTextSetCursor %W insert+1c\n" |
3135 | "break\n" |
3136 | "}\n" |
3137 | "}\n" |
3138 | "bind $win <F9> {\n" |
3139 | "eval destroy [winfo child .]\n" |
3140 | "if {[string equal $tcl_platform(platform) \"macintosh\"]} {\n" |
3141 | "source -rsrc Console\n" |
3142 | "} else {\n" |
3143 | "source [file join $tk_library console.tcl]\n" |
3144 | "}\n" |
3145 | "}\n" |
3146 | "bind $win <<Cut>> {\n" |
3147 | "if {![catch {set data [%W get sel.first sel.last]}]} {\n" |
3148 | "clipboard clear -displayof %W\n" |
3149 | "clipboard append -displayof %W $data\n" |
3150 | "}\n" |
3151 | "break\n" |
3152 | "}\n" |
3153 | "bind $win <<Copy>> {\n" |
3154 | "if {![catch {set data [%W get sel.first sel.last]}]} {\n" |
3155 | "clipboard clear -displayof %W\n" |
3156 | "clipboard append -displayof %W $data\n" |
3157 | "}\n" |
3158 | "break\n" |
3159 | "}\n" |
3160 | "bind $win <<Paste>> {\n" |
3161 | "catch {\n" |
3162 | "set clip [selection get -displayof %W -selection CLIPBOARD]\n" |
3163 | "set list [split $clip \\n\\r]\n" |
3164 | "tkConsoleInsert %W [lindex $list 0]\n" |
3165 | "foreach x [lrange $list 1 end] {\n" |
3166 | "%W mark set insert {end - 1c}\n" |
3167 | "tkConsoleInsert %W \"\\n\"\n" |
3168 | "tkConsoleInvoke\n" |
3169 | "tkConsoleInsert %W $x\n" |
3170 | "}\n" |
3171 | "}\n" |
3172 | "break\n" |
3173 | "}\n" |
3174 | "}\n" |
3175 | "proc tkConsoleInsert {w s} {\n" |
3176 | "if {[string equal $s \"\"]} {\n" |
3177 | "return\n" |
3178 | "}\n" |
3179 | "catch {\n" |
3180 | "if {[$w compare sel.first <= insert]\n" |
3181 | "&& [$w compare sel.last >= insert]} {\n" |
3182 | "$w tag remove sel sel.first promptEnd\n" |
3183 | "$w delete sel.first sel.last\n" |
3184 | "}\n" |
3185 | "}\n" |
3186 | "if {[$w compare insert < promptEnd]} {\n" |
3187 | "$w mark set insert end\011\n" |
3188 | "}\n" |
3189 | "$w insert insert $s {input stdin}\n" |
3190 | "$w see insert\n" |
3191 | "}\n" |
3192 | "proc tkConsoleOutput {dest string} {\n" |
3193 | ".console insert output $string $dest\n" |
3194 | ".console see insert\n" |
3195 | "}\n" |
3196 | "proc tkConsoleExit {} {\n" |
3197 | "destroy .\n" |
3198 | "}\n" |
3199 | "proc tkConsoleAbout {} {\n" |
3200 | "global tk_patchLevel\n" |
3201 | "tk_messageBox -type ok -message \"" |
3202 | BUILD_CONFIG_STATIC_WISH_ALIAS |
3203 | " for Windows, Version " |
3204 | BUILD_CONFIG_RELEASE_VERSION ", " BUILD_CONFIG_RELEASE_YEAR ".\n" |
3205 | "This product is an open-source static port of\n" |
3206 | "Tcl/Tk 8.3.1, originally from Scriptics. This product\n" |
3207 | "and its source code can be downloaded at no charge\n" |
3208 | "from http://ijutools.sourceforge.net, and is licensed\n" |
3209 | "under the GNU Public License (GPL).\n" |
3210 | "(Core components: Tcl [info patchlevel], Tk $tk_patchLevel.)\"\n" |
3211 | "}\n" |
3212 | "tkConsoleInit\n" |
3213 | ; |
3214 | static char Et_zFile13[] = |
3215 | "proc tk_dialog {w title text bitmap default args} {\n" |
3216 | "global tkPriv tcl_platform\n" |
3217 | "if {[string is int $default]} {\n" |
3218 | "if {$default >= [llength $args]} {\n" |
3219 | "return -code error \"default button index greater than number of\\\n" |
3220 | "\011\011 buttons specified for tk_dialog\"\n" |
3221 | "}\n" |
3222 | "} elseif {[string equal {} $default]} {\n" |
3223 | "set default -1\n" |
3224 | "} else {\n" |
3225 | "set default [lsearch -exact $args $default]\n" |
3226 | "}\n" |
3227 | "catch {destroy $w}\n" |
3228 | "toplevel $w -class Dialog\n" |
3229 | "wm title $w $title\n" |
3230 | "wm iconname $w Dialog\n" |
3231 | "wm protocol $w WM_DELETE_WINDOW { }\n" |
3232 | "if { [winfo viewable [winfo toplevel [winfo parent $w]]] } {\n" |
3233 | "wm transient $w [winfo toplevel [winfo parent $w]]\n" |
3234 | "} \n" |
3235 | "if {[string equal $tcl_platform(platform) \"macintosh\"]} {\n" |
3236 | "unsupported1 style $w dBoxProc\n" |
3237 | "}\n" |
3238 | "frame $w.bot\n" |
3239 | "frame $w.top\n" |
3240 | "if {[string equal $tcl_platform(platform) \"unix\"]} {\n" |
3241 | "$w.bot configure -relief raised -bd 1\n" |
3242 | "$w.top configure -relief raised -bd 1\n" |
3243 | "}\n" |
3244 | "pack $w.bot -side bottom -fill both\n" |
3245 | "pack $w.top -side top -fill both -expand 1\n" |
3246 | "option add *Dialog.msg.wrapLength 3i widgetDefault\n" |
3247 | "if {[string equal $tcl_platform(platform) \"macintosh\"]} {\n" |
3248 | "option add *Dialog.msg.font system widgetDefault\n" |
3249 | "} else {\n" |
3250 | "option add *Dialog.msg.font {Times 12} widgetDefault\n" |
3251 | "}\n" |
3252 | "label $w.msg -justify left -text $text\n" |
3253 | "pack $w.msg -in $w.top -side right -expand 1 -fill both -padx 3m -pady 3m\n" |
3254 | "if {[string compare $bitmap \"\"]} {\n" |
3255 | "if {[string equal $tcl_platform(platform) \"macintosh\"] && \\\n" |
3256 | "\011\011[string equal $bitmap \"error\"]} {\n" |
3257 | "set bitmap \"stop\"\n" |
3258 | "}\n" |
3259 | "label $w.bitmap -bitmap $bitmap\n" |
3260 | "pack $w.bitmap -in $w.top -side left -padx 3m -pady 3m\n" |
3261 | "}\n" |
3262 | "set i 0\n" |
3263 | "foreach but $args {\n" |
3264 | "button $w.button$i -text $but -command [list set tkPriv(button) $i]\n" |
3265 | "if {$i == $default} {\n" |
3266 | "$w.button$i configure -default active\n" |
3267 | "} else {\n" |
3268 | "$w.button$i configure -default normal\n" |
3269 | "}\n" |
3270 | "grid $w.button$i -in $w.bot -column $i -row 0 -sticky ew -padx 10\n" |
3271 | "grid columnconfigure $w.bot $i\n" |
3272 | "if {[string equal $tcl_platform(platform) \"macintosh\"]} {\n" |
3273 | "set tmp [string tolower $but]\n" |
3274 | "if {[string equal $tmp \"ok\"] || [string equal $tmp \"cancel\"]} {\n" |
3275 | "grid columnconfigure $w.bot $i -minsize [expr {59 + 20}]\n" |
3276 | "}\n" |
3277 | "}\n" |
3278 | "incr i\n" |
3279 | "}\n" |
3280 | "if {$default >= 0} {\n" |
3281 | "bind $w <Return> \"\n" |
3282 | "[list $w.button$default] configure -state active -relief sunken\n" |
3283 | "update idletasks\n" |
3284 | "after 100\n" |
3285 | "set tkPriv(button) $default\n" |
3286 | "\"\n" |
3287 | "}\n" |
3288 | "bind $w <Destroy> {set tkPriv(button) -1}\n" |
3289 | "wm withdraw $w\n" |
3290 | "update idletasks\n" |
3291 | "set x [expr {[winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \\\n" |
3292 | "\011 - [winfo vrootx [winfo parent $w]]}]\n" |
3293 | "set y [expr {[winfo screenheight $w]/2 - [winfo reqheight $w]/2 \\\n" |
3294 | "\011 - [winfo vrooty [winfo parent $w]]}]\n" |
3295 | "wm geom $w +$x+$y\n" |
3296 | "wm deiconify $w\n" |
3297 | "set oldFocus [focus]\n" |
3298 | "set oldGrab [grab current $w]\n" |
3299 | "if {[string compare $oldGrab \"\"]} {\n" |
3300 | "set grabStatus [grab status $oldGrab]\n" |
3301 | "}\n" |
3302 | "grab $w\n" |
3303 | "if {$default >= 0} {\n" |
3304 | "focus $w.button$default\n" |
3305 | "} else {\n" |
3306 | "focus $w\n" |
3307 | "}\n" |
3308 | "tkwait variable tkPriv(button)\n" |
3309 | "catch {focus $oldFocus}\n" |
3310 | "catch {\n" |
3311 | "bind $w <Destroy> {}\n" |
3312 | "destroy $w\n" |
3313 | "}\n" |
3314 | "if {[string compare $oldGrab \"\"]} {\n" |
3315 | "if {[string compare $grabStatus \"global\"]} {\n" |
3316 | "grab $oldGrab\n" |
3317 | "} else {\n" |
3318 | "grab -global $oldGrab\n" |
3319 | "}\n" |
3320 | "}\n" |
3321 | "return $tkPriv(button)\n" |
3322 | "}\n" |
3323 | ; |
3324 | static char Et_zFile14[] = |
3325 | "bind Entry <<Cut>> {\n" |
3326 | "if {![catch {tkEntryGetSelection %W} tkPriv(data)]} {\n" |
3327 | "clipboard clear -displayof %W\n" |
3328 | "clipboard append -displayof %W $tkPriv(data)\n" |
3329 | "%W delete sel.first sel.last\n" |
3330 | "unset tkPriv(data)\n" |
3331 | "}\n" |
3332 | "}\n" |
3333 | "bind Entry <<Copy>> {\n" |
3334 | "if {![catch {tkEntryGetSelection %W} tkPriv(data)]} {\n" |
3335 | "clipboard clear -displayof %W\n" |
3336 | "clipboard append -displayof %W $tkPriv(data)\n" |
3337 | "unset tkPriv(data)\n" |
3338 | "}\n" |
3339 | "}\n" |
3340 | "bind Entry <<Paste>> {\n" |
3341 | "global tcl_platform\n" |
3342 | "catch {\n" |
3343 | "if {[string compare $tcl_platform(platform) \"unix\"]} {\n" |
3344 | "catch {\n" |
3345 | "%W delete sel.first sel.last\n" |
3346 | "}\n" |
3347 | "}\n" |
3348 | "%W insert insert [selection get -displayof %W -selection CLIPBOARD]\n" |
3349 | "tkEntrySeeInsert %W\n" |
3350 | "}\n" |
3351 | "}\n" |
3352 | "bind Entry <<Clear>> {\n" |
3353 | "%W delete sel.first sel.last\n" |
3354 | "}\n" |
3355 | "bind Entry <<PasteSelection>> {\n" |
3356 | "if {!$tkPriv(mouseMoved) || $tk_strictMotif} {\n" |
3357 | "tkEntryPaste %W %x\n" |
3358 | "}\n" |
3359 | "}\n" |
3360 | "bind Entry <1> {\n" |
3361 | "tkEntryButton1 %W %x\n" |
3362 | "%W selection clear\n" |
3363 | "}\n" |
3364 | "bind Entry <B1-Motion> {\n" |
3365 | "set tkPriv(x) %x\n" |
3366 | "tkEntryMouseSelect %W %x\n" |
3367 | "}\n" |
3368 | "bind Entry <Double-1> {\n" |
3369 | "set tkPriv(selectMode) word\n" |
3370 | "tkEntryMouseSelect %W %x\n" |
3371 | "catch {%W icursor sel.first}\n" |
3372 | "}\n" |
3373 | "bind Entry <Triple-1> {\n" |
3374 | "set tkPriv(selectMode) line\n" |
3375 | "tkEntryMouseSelect %W %x\n" |
3376 | "%W icursor 0\n" |
3377 | "}\n" |
3378 | "bind Entry <Shift-1> {\n" |
3379 | "set tkPriv(selectMode) char\n" |
3380 | "%W selection adjust @%x\n" |
3381 | "}\n" |
3382 | "bind Entry <Double-Shift-1>\011{\n" |
3383 | "set tkPriv(selectMode) word\n" |
3384 | "tkEntryMouseSelect %W %x\n" |
3385 | "}\n" |
3386 | "bind Entry <Triple-Shift-1>\011{\n" |
3387 | "set tkPriv(selectMode) line\n" |
3388 | "tkEntryMouseSelect %W %x\n" |
3389 | "}\n" |
3390 | "bind Entry <B1-Leave> {\n" |
3391 | "set tkPriv(x) %x\n" |
3392 | "tkEntryAutoScan %W\n" |
3393 | "}\n" |
3394 | "bind Entry <B1-Enter> {\n" |
3395 | "tkCancelRepeat\n" |
3396 | "}\n" |
3397 | "bind Entry <ButtonRelease-1> {\n" |
3398 | "tkCancelRepeat\n" |
3399 | "}\n" |
3400 | "bind Entry <Control-1> {\n" |
3401 | "%W icursor @%x\n" |
3402 | "}\n" |
3403 | "bind Entry <Left> {\n" |
3404 | "tkEntrySetCursor %W [expr {[%W index insert] - 1}]\n" |
3405 | "}\n" |
3406 | "bind Entry <Right> {\n" |
3407 | "tkEntrySetCursor %W [expr {[%W index insert] + 1}]\n" |
3408 | "}\n" |
3409 | "bind Entry <Shift-Left> {\n" |
3410 | "tkEntryKeySelect %W [expr {[%W index insert] - 1}]\n" |
3411 | "tkEntrySeeInsert %W\n" |
3412 | "}\n" |
3413 | "bind Entry <Shift-Right> {\n" |
3414 | "tkEntryKeySelect %W [expr {[%W index insert] + 1}]\n" |
3415 | "tkEntrySeeInsert %W\n" |
3416 | "}\n" |
3417 | "bind Entry <Control-Left> {\n" |
3418 | "tkEntrySetCursor %W [tkEntryPreviousWord %W insert]\n" |
3419 | "}\n" |
3420 | "bind Entry <Control-Right> {\n" |
3421 | "tkEntrySetCursor %W [tkEntryNextWord %W insert]\n" |
3422 | "}\n" |
3423 | "bind Entry <Shift-Control-Left> {\n" |
3424 | "tkEntryKeySelect %W [tkEntryPreviousWord %W insert]\n" |
3425 | "tkEntrySeeInsert %W\n" |
3426 | "}\n" |
3427 | "bind Entry <Shift-Control-Right> {\n" |
3428 | "tkEntryKeySelect %W [tkEntryNextWord %W insert]\n" |
3429 | "tkEntrySeeInsert %W\n" |
3430 | "}\n" |
3431 | "bind Entry <Home> {\n" |
3432 | "tkEntrySetCursor %W 0\n" |
3433 | "}\n" |
3434 | "bind Entry <Shift-Home> {\n" |
3435 | "tkEntryKeySelect %W 0\n" |
3436 | "tkEntrySeeInsert %W\n" |
3437 | "}\n" |
3438 | "bind Entry <End> {\n" |
3439 | "tkEntrySetCursor %W end\n" |
3440 | "}\n" |
3441 | "bind Entry <Shift-End> {\n" |
3442 | "tkEntryKeySelect %W end\n" |
3443 | "tkEntrySeeInsert %W\n" |
3444 | "}\n" |
3445 | "bind Entry <Delete> {\n" |
3446 | "if {[%W selection present]} {\n" |
3447 | "%W delete sel.first sel.last\n" |
3448 | "} else {\n" |
3449 | "%W delete insert\n" |
3450 | "}\n" |
3451 | "}\n" |
3452 | "bind Entry <BackSpace> {\n" |
3453 | "tkEntryBackspace %W\n" |
3454 | "}\n" |
3455 | "bind Entry <Control-space> {\n" |
3456 | "%W selection from insert\n" |
3457 | "}\n" |
3458 | "bind Entry <Select> {\n" |
3459 | "%W selection from insert\n" |
3460 | "}\n" |
3461 | "bind Entry <Control-Shift-space> {\n" |
3462 | "%W selection adjust insert\n" |
3463 | "}\n" |
3464 | "bind Entry <Shift-Select> {\n" |
3465 | "%W selection adjust insert\n" |
3466 | "}\n" |
3467 | "bind Entry <Control-slash> {\n" |
3468 | "%W selection range 0 end\n" |
3469 | "}\n" |
3470 | "bind Entry <Control-backslash> {\n" |
3471 | "%W selection clear\n" |
3472 | "}\n" |
3473 | "bind Entry <KeyPress> {\n" |
3474 | "tkEntryInsert %W %A\n" |
3475 | "}\n" |
3476 | "bind Entry <Alt-KeyPress> {# nothing}\n" |
3477 | "bind Entry <Meta-KeyPress> {# nothing}\n" |
3478 | "bind Entry <Control-KeyPress> {# nothing}\n" |
3479 | "bind Entry <Escape> {# nothing}\n" |
3480 | "bind Entry <Return> {# nothing}\n" |
3481 | "bind Entry <KP_Enter> {# nothing}\n" |
3482 | "bind Entry <Tab> {# nothing}\n" |
3483 | "if {[string equal $tcl_platform(platform) \"macintosh\"]} {\n" |
3484 | "bind Entry <Command-KeyPress> {# nothing}\n" |
3485 | "}\n" |
3486 | "if {[string compare $tcl_platform(platform) \"windows\"]} {\n" |
3487 | "bind Entry <Insert> {\n" |
3488 | "catch {tkEntryInsert %W [selection get -displayof %W]}\n" |
3489 | "}\n" |
3490 | "}\n" |
3491 | "bind Entry <Control-a> {\n" |
3492 | "if {!$tk_strictMotif} {\n" |
3493 | "tkEntrySetCursor %W 0\n" |
3494 | "}\n" |
3495 | "}\n" |
3496 | "bind Entry <Control-b> {\n" |
3497 | "if {!$tk_strictMotif} {\n" |
3498 | "tkEntrySetCursor %W [expr {[%W index insert] - 1}]\n" |
3499 | "}\n" |
3500 | "}\n" |
3501 | "bind Entry <Control-d> {\n" |
3502 | "if {!$tk_strictMotif} {\n" |
3503 | "%W delete insert\n" |
3504 | "}\n" |
3505 | "}\n" |
3506 | "bind Entry <Control-e> {\n" |
3507 | "if {!$tk_strictMotif} {\n" |
3508 | "tkEntrySetCursor %W end\n" |
3509 | "}\n" |
3510 | "}\n" |
3511 | "bind Entry <Control-f> {\n" |
3512 | "if {!$tk_strictMotif} {\n" |
3513 | "tkEntrySetCursor %W [expr {[%W index insert] + 1}]\n" |
3514 | "}\n" |
3515 | "}\n" |
3516 | "bind Entry <Control-h> {\n" |
3517 | "if {!$tk_strictMotif} {\n" |
3518 | "tkEntryBackspace %W\n" |
3519 | "}\n" |
3520 | "}\n" |
3521 | "bind Entry <Control-k> {\n" |
3522 | "if {!$tk_strictMotif} {\n" |
3523 | "%W delete insert end\n" |
3524 | "}\n" |
3525 | "}\n" |
3526 | "bind Entry <Control-t> {\n" |
3527 | "if {!$tk_strictMotif} {\n" |
3528 | "tkEntryTranspose %W\n" |
3529 | "}\n" |
3530 | "}\n" |
3531 | "bind Entry <Meta-b> {\n" |
3532 | "if {!$tk_strictMotif} {\n" |
3533 | "tkEntrySetCursor %W [tkEntryPreviousWord %W insert]\n" |
3534 | "}\n" |
3535 | "}\n" |
3536 | "bind Entry <Meta-d> {\n" |
3537 | "if {!$tk_strictMotif} {\n" |
3538 | "%W delete insert [tkEntryNextWord %W insert]\n" |
3539 | "}\n" |
3540 | "}\n" |
3541 | "bind Entry <Meta-f> {\n" |
3542 | "if {!$tk_strictMotif} {\n" |
3543 | "tkEntrySetCursor %W [tkEntryNextWord %W insert]\n" |
3544 | "}\n" |
3545 | "}\n" |
3546 | "bind Entry <Meta-BackSpace> {\n" |
3547 | "if {!$tk_strictMotif} {\n" |
3548 | "%W delete [tkEntryPreviousWord %W insert] insert\n" |
3549 | "}\n" |
3550 | "}\n" |
3551 | "bind Entry <Meta-Delete> {\n" |
3552 | "if {!$tk_strictMotif} {\n" |
3553 | "%W delete [tkEntryPreviousWord %W insert] insert\n" |
3554 | "}\n" |
3555 | "}\n" |
3556 | "bind Entry <2> {\n" |
3557 | "if {!$tk_strictMotif} {\n" |
3558 | "%W scan mark %x\n" |
3559 | "set tkPriv(x) %x\n" |
3560 | "set tkPriv(y) %y\n" |
3561 | "set tkPriv(mouseMoved) 0\n" |
3562 | "}\n" |
3563 | "}\n" |
3564 | "bind Entry <B2-Motion> {\n" |
3565 | "if {!$tk_strictMotif} {\n" |
3566 | "if {abs(%x-$tkPriv(x)) > 2} {\n" |
3567 | "set tkPriv(mouseMoved) 1\n" |
3568 | "}\n" |
3569 | "%W scan dragto %x\n" |
3570 | "}\n" |
3571 | "}\n" |
3572 | "proc tkEntryClosestGap {w x} {\n" |
3573 | "set pos [$w index @$x]\n" |
3574 | "set bbox [$w bbox $pos]\n" |
3575 | "if {($x - [lindex $bbox 0]) < ([lindex $bbox 2]/2)} {\n" |
3576 | "return $pos\n" |
3577 | "}\n" |
3578 | "incr pos\n" |
3579 | "}\n" |
3580 | "proc tkEntryButton1 {w x} {\n" |
3581 | "global tkPriv\n" |
3582 | "set tkPriv(selectMode) char\n" |
3583 | "set tkPriv(mouseMoved) 0\n" |
3584 | "set tkPriv(pressX) $x\n" |
3585 | "$w icursor [tkEntryClosestGap $w $x]\n" |
3586 | "$w selection from insert\n" |
3587 | "if {[string equal [$w cget -state] \"normal\"]} {focus $w}\n" |
3588 | "}\n" |
3589 | "proc tkEntryMouseSelect {w x} {\n" |
3590 | "global tkPriv\n" |
3591 | "set cur [tkEntryClosestGap $w $x]\n" |
3592 | "set anchor [$w index anchor]\n" |
3593 | "if {($cur != $anchor) || (abs($tkPriv(pressX) - $x) >= 3)} {\n" |
3594 | "set tkPriv(mouseMoved) 1\n" |
3595 | "}\n" |
3596 | "switch $tkPriv(selectMode) {\n" |
3597 | "char {\n" |
3598 | "if {$tkPriv(mouseMoved)} {\n" |
3599 | "if {$cur < $anchor} {\n" |
3600 | "$w selection range $cur $anchor\n" |
3601 | "} elseif {$cur > $anchor} {\n" |
3602 | "$w selection range $anchor $cur\n" |
3603 | "} else {\n" |
3604 | "$w selection clear\n" |
3605 | "}\n" |
3606 | "}\n" |
3607 | "}\n" |
3608 | "word {\n" |
3609 | "if {$cur < [$w index anchor]} {\n" |
3610 | "set before [tcl_wordBreakBefore [$w get] $cur]\n" |
3611 | "set after [tcl_wordBreakAfter [$w get] [expr {$anchor-1}]]\n" |
3612 | "} else {\n" |
3613 | "set before [tcl_wordBreakBefore [$w get] $anchor]\n" |
3614 | "set after [tcl_wordBreakAfter [$w get] [expr {$cur - 1}]]\n" |
3615 | "}\n" |
3616 | "if {$before < 0} {\n" |
3617 | "set before 0\n" |
3618 | "}\n" |
3619 | "if {$after < 0} {\n" |
3620 | "set after end\n" |
3621 | "}\n" |
3622 | "$w selection range $before $after\n" |
3623 | "}\n" |
3624 | "line {\n" |
3625 | "$w selection range 0 end\n" |
3626 | "}\n" |
3627 | "}\n" |
3628 | "update idletasks\n" |
3629 | "}\n" |
3630 | "proc tkEntryPaste {w x} {\n" |
3631 | "global tkPriv\n" |
3632 | "$w icursor [tkEntryClosestGap $w $x]\n" |
3633 | "catch {$w insert insert [selection get -displayof $w]}\n" |
3634 | "if {[string equal [$w cget -state] \"normal\"]} {focus $w}\n" |
3635 | "}\n" |
3636 | "proc tkEntryAutoScan {w} {\n" |
3637 | "global tkPriv\n" |
3638 | "set x $tkPriv(x)\n" |
3639 | "if {![winfo exists $w]} return\n" |
3640 | "if {$x >= [winfo width $w]} {\n" |
3641 | "$w xview scroll 2 units\n" |
3642 | "tkEntryMouseSelect $w $x\n" |
3643 | "} elseif {$x < 0} {\n" |
3644 | "$w xview scroll -2 units\n" |
3645 | "tkEntryMouseSelect $w $x\n" |
3646 | "}\n" |
3647 | "set tkPriv(afterId) [after 50 [list tkEntryAutoScan $w]]\n" |
3648 | "}\n" |
3649 | "proc tkEntryKeySelect {w new} {\n" |
3650 | "if {![$w selection present]} {\n" |
3651 | "$w selection from insert\n" |
3652 | "$w selection to $new\n" |
3653 | "} else {\n" |
3654 | "$w selection adjust $new\n" |
3655 | "}\n" |
3656 | "$w icursor $new\n" |
3657 | "}\n" |
3658 | "proc tkEntryInsert {w s} {\n" |
3659 | "if {[string equal $s \"\"]} {\n" |
3660 | "return\n" |
3661 | "}\n" |
3662 | "catch {\n" |
3663 | "set insert [$w index insert]\n" |
3664 | "if {([$w index sel.first] <= $insert)\n" |
3665 | "&& ([$w index sel.last] >= $insert)} {\n" |
3666 | "$w delete sel.first sel.last\n" |
3667 | "}\n" |
3668 | "}\n" |
3669 | "$w insert insert $s\n" |
3670 | "tkEntrySeeInsert $w\n" |
3671 | "}\n" |
3672 | "proc tkEntryBackspace w {\n" |
3673 | "if {[$w selection present]} {\n" |
3674 | "$w delete sel.first sel.last\n" |
3675 | "} else {\n" |
3676 | "set x [expr {[$w index insert] - 1}]\n" |
3677 | "if {$x >= 0} {$w delete $x}\n" |
3678 | "if {[$w index @0] >= [$w index insert]} {\n" |
3679 | "set range [$w xview]\n" |
3680 | "set left [lindex $range 0]\n" |
3681 | "set right [lindex $range 1]\n" |
3682 | "$w xview moveto [expr {$left - ($right - $left)/2.0}]\n" |
3683 | "}\n" |
3684 | "}\n" |
3685 | "}\n" |
3686 | "proc tkEntrySeeInsert w {\n" |
3687 | "set c [$w index insert]\n" |
3688 | "if {($c < [$w index @0]) || ($c > [$w index @[winfo width $w]])} {\n" |
3689 | "$w xview $c\n" |
3690 | "}\n" |
3691 | "}\n" |
3692 | "proc tkEntrySetCursor {w pos} {\n" |
3693 | "$w icursor $pos\n" |
3694 | "$w selection clear\n" |
3695 | "tkEntrySeeInsert $w\n" |
3696 | "}\n" |
3697 | "proc tkEntryTranspose w {\n" |
3698 | "set i [$w index insert]\n" |
3699 | "if {$i < [$w index end]} {\n" |
3700 | "incr i\n" |
3701 | "}\n" |
3702 | "set first [expr {$i-2}]\n" |
3703 | "if {$first < 0} {\n" |
3704 | "return\n" |
3705 | "}\n" |
3706 | "set new [string index [$w get] [expr {$i-1}]][string index [$w get] $first]\n" |
3707 | "$w delete $first $i\n" |
3708 | "$w insert insert $new\n" |
3709 | "tkEntrySeeInsert $w\n" |
3710 | "}\n" |
3711 | "if {[string equal $tcl_platform(platform) \"windows\"]} {\n" |
3712 | "proc tkEntryNextWord {w start} {\n" |
3713 | "set pos [tcl_endOfWord [$w get] [$w index $start]]\n" |
3714 | "if {$pos >= 0} {\n" |
3715 | "set pos [tcl_startOfNextWord [$w get] $pos]\n" |
3716 | "}\n" |
3717 | "if {$pos < 0} {\n" |
3718 | "return end\n" |
3719 | "}\n" |
3720 | "return $pos\n" |
3721 | "}\n" |
3722 | "} else {\n" |
3723 | "proc tkEntryNextWord {w start} {\n" |
3724 | "set pos [tcl_endOfWord [$w get] [$w index $start]]\n" |
3725 | "if {$pos < 0} {\n" |
3726 | "return end\n" |
3727 | "}\n" |
3728 | "return $pos\n" |
3729 | "}\n" |
3730 | "}\n" |
3731 | "proc tkEntryPreviousWord {w start} {\n" |
3732 | "set pos [tcl_startOfPreviousWord [$w get] [$w index $start]]\n" |
3733 | "if {$pos < 0} {\n" |
3734 | "return 0\n" |
3735 | "}\n" |
3736 | "return $pos\n" |
3737 | "}\n" |
3738 | "proc tkEntryGetSelection {w} {\n" |
3739 | "set entryString [string range [$w get] [$w index sel.first] \\\n" |
3740 | "\011 [expr {[$w index sel.last] - 1}]]\n" |
3741 | "if {[string compare [$w cget -show] \"\"]} {\n" |
3742 | "regsub -all . $entryString [string index [$w cget -show] 0] entryString\n" |
3743 | "}\n" |
3744 | "return $entryString\n" |
3745 | "}\n" |
3746 | ; |
3747 | static char Et_zFile15[] = |
3748 | "proc tk_focusNext w {\n" |
3749 | "set cur $w\n" |
3750 | "while {1} {\n" |
3751 | "set parent $cur\n" |
3752 | "set children [winfo children $cur]\n" |
3753 | "set i -1\n" |
3754 | "while {1} {\n" |
3755 | "incr i\n" |
3756 | "if {$i < [llength $children]} {\n" |
3757 | "set cur [lindex $children $i]\n" |
3758 | "if {[string equal [winfo toplevel $cur] $cur]} {\n" |
3759 | "continue\n" |
3760 | "} else {\n" |
3761 | "break\n" |
3762 | "}\n" |
3763 | "}\n" |
3764 | "set cur $parent\n" |
3765 | "if {[string equal [winfo toplevel $cur] $cur]} {\n" |
3766 | "break\n" |
3767 | "}\n" |
3768 | "set parent [winfo parent $parent]\n" |
3769 | "set children [winfo children $parent]\n" |
3770 | "set i [lsearch -exact $children $cur]\n" |
3771 | "}\n" |
3772 | "if {[string equal $w $cur] || [tkFocusOK $cur]} {\n" |
3773 | "return $cur\n" |
3774 | "}\n" |
3775 | "}\n" |
3776 | "}\n" |
3777 | "proc tk_focusPrev w {\n" |
3778 | "set cur $w\n" |
3779 | "while {1} {\n" |
3780 | "if {[string equal [winfo toplevel $cur] $cur]} {\n" |
3781 | "set parent $cur\n" |
3782 | "set children [winfo children $cur]\n" |
3783 | "set i [llength $children]\n" |
3784 | "} else {\n" |
3785 | "set parent [winfo parent $cur]\n" |
3786 | "set children [winfo children $parent]\n" |
3787 | "set i [lsearch -exact $children $cur]\n" |
3788 | "}\n" |
3789 | "while {$i > 0} {\n" |
3790 | "incr i -1\n" |
3791 | "set cur [lindex $children $i]\n" |
3792 | "if {[string equal [winfo toplevel $cur] $cur]} {\n" |
3793 | "continue\n" |
3794 | "}\n" |
3795 | "set parent $cur\n" |
3796 | "set children [winfo children $parent]\n" |
3797 | "set i [llength $children]\n" |
3798 | "}\n" |
3799 | "set cur $parent\n" |
3800 | "if {[string equal $w $cur] || [tkFocusOK $cur]} {\n" |
3801 | "return $cur\n" |
3802 | "}\n" |
3803 | "}\n" |
3804 | "}\n" |
3805 | "proc tkFocusOK w {\n" |
3806 | "set code [catch {$w cget -takefocus} value]\n" |
3807 | "if {($code == 0) && [string compare $value \"\"]} {\n" |
3808 | "if {$value == 0} {\n" |
3809 | "return 0\n" |
3810 | "} elseif {$value == 1} {\n" |
3811 | "return [winfo viewable $w]\n" |
3812 | "} else {\n" |
3813 | "set value [uplevel #0 [list $value $w]]\n" |
3814 | "if {[string compare $value \"\"]} {\n" |
3815 | "return $value\n" |
3816 | "}\n" |
3817 | "}\n" |
3818 | "}\n" |
3819 | "if {![winfo viewable $w]} {\n" |
3820 | "return 0\n" |
3821 | "}\n" |
3822 | "set code [catch {$w cget -state} value]\n" |
3823 | "if {($code == 0) && [string equal $value \"disabled\"]} {\n" |
3824 | "return 0\n" |
3825 | "}\n" |
3826 | "regexp Key|Focus \"[bind $w] [bind [winfo class $w]]\"\n" |
3827 | "}\n" |
3828 | "proc tk_focusFollowsMouse {} {\n" |
3829 | "set old [bind all <Enter>]\n" |
3830 | "set script {\n" |
3831 | "if {[string equal \"%d\" \"NotifyAncestor\"] \\\n" |
3832 | "\011\011|| [string equal \"%d\" \"NotifyNonlinear\"] \\\n" |
3833 | "\011\011|| [string equal \"%d\" \"NotifyInferior\"]} {\n" |
3834 | "if {[tkFocusOK %W]} {\n" |
3835 | "focus %W\n" |
3836 | "}\n" |
3837 | "}\n" |
3838 | "}\n" |
3839 | "if {[string compare $old \"\"]} {\n" |
3840 | "bind all <Enter> \"$old; $script\"\n" |
3841 | "} else {\n" |
3842 | "bind all <Enter> $script\n" |
3843 | "}\n" |
3844 | "}\n" |
3845 | ; |
3846 | static char Et_zFile16[] = |
3847 | "bind Listbox <1> {\n" |
3848 | "if {[winfo exists %W]} {\n" |
3849 | "tkListboxBeginSelect %W [%W index @%x,%y]\n" |
3850 | "}\n" |
3851 | "}\n" |
3852 | "bind Listbox <Double-1> {\n" |
3853 | "}\n" |
3854 | "bind Listbox <B1-Motion> {\n" |
3855 | "set tkPriv(x) %x\n" |
3856 | "set tkPriv(y) %y\n" |
3857 | "tkListboxMotion %W [%W index @%x,%y]\n" |
3858 | "}\n" |
3859 | "bind Listbox <ButtonRelease-1> {\n" |
3860 | "tkCancelRepeat\n" |
3861 | "%W activate @%x,%y\n" |
3862 | "}\n" |
3863 | "bind Listbox <Shift-1> {\n" |
3864 | "tkListboxBeginExtend %W [%W index @%x,%y]\n" |
3865 | "}\n" |
3866 | "bind Listbox <Control-1> {\n" |
3867 | "tkListboxBeginToggle %W [%W index @%x,%y]\n" |
3868 | "}\n" |
3869 | "bind Listbox <B1-Leave> {\n" |
3870 | "set tkPriv(x) %x\n" |
3871 | "set tkPriv(y) %y\n" |
3872 | "tkListboxAutoScan %W\n" |
3873 | "}\n" |
3874 | "bind Listbox <B1-Enter> {\n" |
3875 | "tkCancelRepeat\n" |
3876 | "}\n" |
3877 | "bind Listbox <Up> {\n" |
3878 | "tkListboxUpDown %W -1\n" |
3879 | "}\n" |
3880 | "bind Listbox <Shift-Up> {\n" |
3881 | "tkListboxExtendUpDown %W -1\n" |
3882 | "}\n" |
3883 | "bind Listbox <Down> {\n" |
3884 | "tkListboxUpDown %W 1\n" |
3885 | "}\n" |
3886 | "bind Listbox <Shift-Down> {\n" |
3887 | "tkListboxExtendUpDown %W 1\n" |
3888 | "}\n" |
3889 | "bind Listbox <Left> {\n" |
3890 | "%W xview scroll -1 units\n" |
3891 | "}\n" |
3892 | "bind Listbox <Control-Left> {\n" |
3893 | "%W xview scroll -1 pages\n" |
3894 | "}\n" |
3895 | "bind Listbox <Right> {\n" |
3896 | "%W xview scroll 1 units\n" |
3897 | "}\n" |
3898 | "bind Listbox <Control-Right> {\n" |
3899 | "%W xview scroll 1 pages\n" |
3900 | "}\n" |
3901 | "bind Listbox <Prior> {\n" |
3902 | "%W yview scroll -1 pages\n" |
3903 | "%W activate @0,0\n" |
3904 | "}\n" |
3905 | "bind Listbox <Next> {\n" |
3906 | "%W yview scroll 1 pages\n" |
3907 | "%W activate @0,0\n" |
3908 | "}\n" |
3909 | "bind Listbox <Control-Prior> {\n" |
3910 | "%W xview scroll -1 pages\n" |
3911 | "}\n" |
3912 | "bind Listbox <Control-Next> {\n" |
3913 | "%W xview scroll 1 pages\n" |
3914 | "}\n" |
3915 | "bind Listbox <Home> {\n" |
3916 | "%W xview moveto 0\n" |
3917 | "}\n" |
3918 | "bind Listbox <End> {\n" |
3919 | "%W xview moveto 1\n" |
3920 | "}\n" |
3921 | "bind Listbox <Control-Home> {\n" |
3922 | "%W activate 0\n" |
3923 | "%W see 0\n" |
3924 | "%W selection clear 0 end\n" |
3925 | "%W selection set 0\n" |
3926 | "event generate %W <<ListboxSelect>>\n" |
3927 | "}\n" |
3928 | "bind Listbox <Shift-Control-Home> {\n" |
3929 | "tkListboxDataExtend %W 0\n" |
3930 | "}\n" |
3931 | "bind Listbox <Control-End> {\n" |
3932 | "%W activate end\n" |
3933 | "%W see end\n" |
3934 | "%W selection clear 0 end\n" |
3935 | "%W selection set end\n" |
3936 | "event generate %W <<ListboxSelect>>\n" |
3937 | "}\n" |
3938 | "bind Listbox <Shift-Control-End> {\n" |
3939 | "tkListboxDataExtend %W [%W index end]\n" |
3940 | "}\n" |
3941 | "bind Listbox <<Copy>> {\n" |
3942 | "if {[string equal [selection own -displayof %W] \"%W\"]} {\n" |
3943 | "clipboard clear -displayof %W\n" |
3944 | "clipboard append -displayof %W [selection get -displayof %W]\n" |
3945 | "}\n" |
3946 | "}\n" |
3947 | "bind Listbox <space> {\n" |
3948 | "tkListboxBeginSelect %W [%W index active]\n" |
3949 | "}\n" |
3950 | "bind Listbox <Select> {\n" |
3951 | "tkListboxBeginSelect %W [%W index active]\n" |
3952 | "}\n" |
3953 | "bind Listbox <Control-Shift-space> {\n" |
3954 | "tkListboxBeginExtend %W [%W index active]\n" |
3955 | "}\n" |
3956 | "bind Listbox <Shift-Select> {\n" |
3957 | "tkListboxBeginExtend %W [%W index active]\n" |
3958 | "}\n" |
3959 | "bind Listbox <Escape> {\n" |
3960 | "tkListboxCancel %W\n" |
3961 | "}\n" |
3962 | "bind Listbox <Control-slash> {\n" |
3963 | "tkListboxSelectAll %W\n" |
3964 | "}\n" |
3965 | "bind Listbox <Control-backslash> {\n" |
3966 | "if {[string compare [%W cget -selectmode] \"browse\"]} {\n" |
3967 | "%W selection clear 0 end\n" |
3968 | "event generate %W <<ListboxSelect>>\n" |
3969 | "}\n" |
3970 | "}\n" |
3971 | "bind Listbox <2> {\n" |
3972 | "%W scan mark %x %y\n" |
3973 | "}\n" |
3974 | "bind Listbox <B2-Motion> {\n" |
3975 | "%W scan dragto %x %y\n" |
3976 | "}\n" |
3977 | "bind Listbox <MouseWheel> {\n" |
3978 | "%W yview scroll [expr {- (%D / 120) * 4}] units\n" |
3979 | "}\n" |
3980 | "if {[string equal \"unix\" $tcl_platform(platform)]} {\n" |
3981 | "bind Listbox <4> {\n" |
3982 | "if {!$tk_strictMotif} {\n" |
3983 | "%W yview scroll -5 units\n" |
3984 | "}\n" |
3985 | "}\n" |
3986 | "bind Listbox <5> {\n" |
3987 | "if {!$tk_strictMotif} {\n" |
3988 | "%W yview scroll 5 units\n" |
3989 | "}\n" |
3990 | "}\n" |
3991 | "}\n" |
3992 | "proc tkListboxBeginSelect {w el} {\n" |
3993 | "global tkPriv\n" |
3994 | "if {[string equal [$w cget -selectmode] \"multiple\"]} {\n" |
3995 | "if {[$w selection includes $el]} {\n" |
3996 | "$w selection clear $el\n" |
3997 | "} else {\n" |
3998 | "$w selection set $el\n" |
3999 | "}\n" |
4000 | "} else {\n" |
4001 | "$w selection clear 0 end\n" |
4002 | "$w selection set $el\n" |
4003 | "$w selection anchor $el\n" |
4004 | "set tkPriv(listboxSelection) {}\n" |
4005 | "set tkPriv(listboxPrev) $el\n" |
4006 | "}\n" |
4007 | "event generate $w <<ListboxSelect>>\n" |
4008 | "}\n" |
4009 | "proc tkListboxMotion {w el} {\n" |
4010 | "global tkPriv\n" |
4011 | "if {$el == $tkPriv(listboxPrev)} {\n" |
4012 | "return\n" |
4013 | "}\n" |
4014 | "set anchor [$w index anchor]\n" |
4015 | "switch [$w cget -selectmode] {\n" |
4016 | "browse {\n" |
4017 | "$w selection clear 0 end\n" |
4018 | "$w selection set $el\n" |
4019 | "set tkPriv(listboxPrev) $el\n" |
4020 | "event generate $w <<ListboxSelect>>\n" |
4021 | "}\n" |
4022 | "extended {\n" |
4023 | "set i $tkPriv(listboxPrev)\n" |
4024 | "if {[string equal {} $i]} {\n" |
4025 | "set i $el\n" |
4026 | "$w selection set $el\n" |
4027 | "}\n" |
4028 | "if {[$w selection includes anchor]} {\n" |
4029 | "$w selection clear $i $el\n" |
4030 | "$w selection set anchor $el\n" |
4031 | "} else {\n" |
4032 | "$w selection clear $i $el\n" |
4033 | "$w selection clear anchor $el\n" |
4034 | "}\n" |
4035 | "if {![info exists tkPriv(listboxSelection)]} {\n" |
4036 | "set tkPriv(listboxSelection) [$w curselection]\n" |
4037 | "}\n" |
4038 | "while {($i < $el) && ($i < $anchor)} {\n" |
4039 | "if {[lsearch $tkPriv(listboxSelection) $i] >= 0} {\n" |
4040 | "$w selection set $i\n" |
4041 | "}\n" |
4042 | "incr i\n" |
4043 | "}\n" |
4044 | "while {($i > $el) && ($i > $anchor)} {\n" |
4045 | "if {[lsearch $tkPriv(listboxSelection) $i] >= 0} {\n" |
4046 | "$w selection set $i\n" |
4047 | "}\n" |
4048 | "incr i -1\n" |
4049 | "}\n" |
4050 | "set tkPriv(listboxPrev) $el\n" |
4051 | "event generate $w <<ListboxSelect>>\n" |
4052 | "}\n" |
4053 | "}\n" |
4054 | "}\n" |
4055 | "proc tkListboxBeginExtend {w el} {\n" |
4056 | "if {[string equal [$w cget -selectmode] \"extended\"]} {\n" |
4057 | "if {[$w selection includes anchor]} {\n" |
4058 | "tkListboxMotion $w $el\n" |
4059 | "} else {\n" |
4060 | "tkListboxBeginSelect $w $el\n" |
4061 | "}\n" |
4062 | "}\n" |
4063 | "}\n" |
4064 | "proc tkListboxBeginToggle {w el} {\n" |
4065 | "global tkPriv\n" |
4066 | "if {[string equal [$w cget -selectmode] \"extended\"]} {\n" |
4067 | "set tkPriv(listboxSelection) [$w curselection]\n" |
4068 | "set tkPriv(listboxPrev) $el\n" |
4069 | "$w selection anchor $el\n" |
4070 | "if {[$w selection includes $el]} {\n" |
4071 | "$w selection clear $el\n" |
4072 | "} else {\n" |
4073 | "$w selection set $el\n" |
4074 | "}\n" |
4075 | "event generate $w <<ListboxSelect>>\n" |
4076 | "}\n" |
4077 | "}\n" |
4078 | "proc tkListboxAutoScan {w} {\n" |
4079 | "global tkPriv\n" |
4080 | "if {![winfo exists $w]} return\n" |
4081 | "set x $tkPriv(x)\n" |
4082 | "set y $tkPriv(y)\n" |
4083 | "if {$y >= [winfo height $w]} {\n" |
4084 | "$w yview scroll 1 units\n" |
4085 | "} elseif {$y < 0} {\n" |
4086 | "$w yview scroll -1 units\n" |
4087 | "} elseif {$x >= [winfo width $w]} {\n" |
4088 | "$w xview scroll 2 units\n" |
4089 | "} elseif {$x < 0} {\n" |
4090 | "$w xview scroll -2 units\n" |
4091 | "} else {\n" |
4092 | "return\n" |
4093 | "}\n" |
4094 | "tkListboxMotion $w [$w index @$x,$y]\n" |
4095 | "set tkPriv(afterId) [after 50 [list tkListboxAutoScan $w]]\n" |
4096 | "}\n" |
4097 | "proc tkListboxUpDown {w amount} {\n" |
4098 | "global tkPriv\n" |
4099 | "$w activate [expr {[$w index active] + $amount}]\n" |
4100 | "$w see active\n" |
4101 | "switch [$w cget -selectmode] {\n" |
4102 | "browse {\n" |
4103 | "$w selection clear 0 end\n" |
4104 | "$w selection set active\n" |
4105 | "event generate $w <<ListboxSelect>>\n" |
4106 | "}\n" |
4107 | "extended {\n" |
4108 | "$w selection clear 0 end\n" |
4109 | "$w selection set active\n" |
4110 | "$w selection anchor active\n" |
4111 | "set tkPriv(listboxPrev) [$w index active]\n" |
4112 | "set tkPriv(listboxSelection) {}\n" |
4113 | "event generate $w <<ListboxSelect>>\n" |
4114 | "}\n" |
4115 | "}\n" |
4116 | "}\n" |
4117 | "proc tkListboxExtendUpDown {w amount} {\n" |
4118 | "if {[string compare [$w cget -selectmode] \"extended\"]} {\n" |
4119 | "return\n" |
4120 | "}\n" |
4121 | "set active [$w index active]\n" |
4122 | "if {![info exists tkPriv(listboxSelection)]} {\n" |
4123 | "global tkPriv\n" |
4124 | "$w selection set $active\n" |
4125 | "set tkPriv(listboxSelection) [$w curselection]\n" |
4126 | "}\n" |
4127 | "$w activate [expr {$active + $amount}]\n" |
4128 | "$w see active\n" |
4129 | "tkListboxMotion $w [$w index active]\n" |
4130 | "}\n" |
4131 | "proc tkListboxDataExtend {w el} {\n" |
4132 | "set mode [$w cget -selectmode]\n" |
4133 | "if {[string equal $mode \"extended\"]} {\n" |
4134 | "$w activate $el\n" |
4135 | "$w see $el\n" |
4136 | "if {[$w selection includes anchor]} {\n" |
4137 | "tkListboxMotion $w $el\n" |
4138 | "}\n" |
4139 | "} elseif {[string equal $mode \"multiple\"]} {\n" |
4140 | "$w activate $el\n" |
4141 | "$w see $el\n" |
4142 | "}\n" |
4143 | "}\n" |
4144 | "proc tkListboxCancel w {\n" |
4145 | "global tkPriv\n" |
4146 | "if {[string compare [$w cget -selectmode] \"extended\"]} {\n" |
4147 | "return\n" |
4148 | "}\n" |
4149 | "set first [$w index anchor]\n" |
4150 | "set last $tkPriv(listboxPrev)\n" |
4151 | "if { [string equal $last \"\"] } {\n" |
4152 | "return\n" |
4153 | "}\n" |
4154 | "if {$first > $last} {\n" |
4155 | "set tmp $first\n" |
4156 | "set first $last\n" |
4157 | "set last $tmp\n" |
4158 | "}\n" |
4159 | "$w selection clear $first $last\n" |
4160 | "while {$first <= $last} {\n" |
4161 | "if {[lsearch $tkPriv(listboxSelection) $first] >= 0} {\n" |
4162 | "$w selection set $first\n" |
4163 | "}\n" |
4164 | "incr first\n" |
4165 | "}\n" |
4166 | "event generate $w <<ListboxSelect>>\n" |
4167 | "}\n" |
4168 | "proc tkListboxSelectAll w {\n" |
4169 | "set mode [$w cget -selectmode]\n" |
4170 | "if {[string equal $mode \"single\"] || [string equal $mode \"browse\"]} {\n" |
4171 | "$w selection clear 0 end\n" |
4172 | "$w selection set active\n" |
4173 | "} else {\n" |
4174 | "$w selection set 0 end\n" |
4175 | "}\n" |
4176 | "event generate $w <<ListboxSelect>>\n" |
4177 | "}\n" |
4178 | ; |
4179 | static char Et_zFile17[] = |
4180 | "bind Menubutton <FocusIn> {}\n" |
4181 | "bind Menubutton <Enter> {\n" |
4182 | "tkMbEnter %W\n" |
4183 | "}\n" |
4184 | "bind Menubutton <Leave> {\n" |
4185 | "tkMbLeave %W\n" |
4186 | "}\n" |
4187 | "bind Menubutton <1> {\n" |
4188 | "if {[string compare $tkPriv(inMenubutton) \"\"]} {\n" |
4189 | "tkMbPost $tkPriv(inMenubutton) %X %Y\n" |
4190 | "}\n" |
4191 | "}\n" |
4192 | "bind Menubutton <Motion> {\n" |
4193 | "tkMbMotion %W up %X %Y\n" |
4194 | "}\n" |
4195 | "bind Menubutton <B1-Motion> {\n" |
4196 | "tkMbMotion %W down %X %Y\n" |
4197 | "}\n" |
4198 | "bind Menubutton <ButtonRelease-1> {\n" |
4199 | "tkMbButtonUp %W\n" |
4200 | "}\n" |
4201 | "bind Menubutton <space> {\n" |
4202 | "tkMbPost %W\n" |
4203 | "tkMenuFirstEntry [%W cget -menu]\n" |
4204 | "}\n" |
4205 | "bind Menu <FocusIn> {}\n" |
4206 | "bind Menu <Enter> {\n" |
4207 | "set tkPriv(window) %W\n" |
4208 | "if {[string equal [%W cget -type] \"tearoff\"]} {\n" |
4209 | "if {[string compare \"%m\" \"NotifyUngrab\"]} {\n" |
4210 | "if {[string equal $tcl_platform(platform) \"unix\"]} {\n" |
4211 | "tk_menuSetFocus %W\n" |
4212 | "}\n" |
4213 | "}\n" |
4214 | "}\n" |
4215 | "tkMenuMotion %W %x %y %s\n" |
4216 | "}\n" |
4217 | "bind Menu <Leave> {\n" |
4218 | "tkMenuLeave %W %X %Y %s\n" |
4219 | "}\n" |
4220 | "bind Menu <Motion> {\n" |
4221 | "tkMenuMotion %W %x %y %s\n" |
4222 | "}\n" |
4223 | "bind Menu <ButtonPress> {\n" |
4224 | "tkMenuButtonDown %W\n" |
4225 | "}\n" |
4226 | "bind Menu <ButtonRelease> {\n" |
4227 | "tkMenuInvoke %W 1\n" |
4228 | "}\n" |
4229 | "bind Menu <space> {\n" |
4230 | "tkMenuInvoke %W 0\n" |
4231 | "}\n" |
4232 | "bind Menu <Return> {\n" |
4233 | "tkMenuInvoke %W 0\n" |
4234 | "}\n" |
4235 | "bind Menu <Escape> {\n" |
4236 | "tkMenuEscape %W\n" |
4237 | "}\n" |
4238 | "bind Menu <Left> {\n" |
4239 | "tkMenuLeftArrow %W\n" |
4240 | "}\n" |
4241 | "bind Menu <Right> {\n" |
4242 | "tkMenuRightArrow %W\n" |
4243 | "}\n" |
4244 | "bind Menu <Up> {\n" |
4245 | "tkMenuUpArrow %W\n" |
4246 | "}\n" |
4247 | "bind Menu <Down> {\n" |
4248 | "tkMenuDownArrow %W\n" |
4249 | "}\n" |
4250 | "bind Menu <KeyPress> {\n" |
4251 | "tkTraverseWithinMenu %W %A\n" |
4252 | "}\n" |
4253 | "if {[string equal $tcl_platform(platform) \"unix\"]} {\n" |
4254 | "bind all <Alt-KeyPress> {\n" |
4255 | "tkTraverseToMenu %W %A\n" |
4256 | "}\n" |
4257 | "bind all <F10> {\n" |
4258 | "tkFirstMenu %W\n" |
4259 | "}\n" |
4260 | "} else {\n" |
4261 | "bind Menubutton <Alt-KeyPress> {\n" |
4262 | "tkTraverseToMenu %W %A\n" |
4263 | "}\n" |
4264 | "bind Menubutton <F10> {\n" |
4265 | "tkFirstMenu %W\n" |
4266 | "}\n" |
4267 | "}\n" |
4268 | "proc tkMbEnter w {\n" |
4269 | "global tkPriv\n" |
4270 | "if {[string compare $tkPriv(inMenubutton) \"\"]} {\n" |
4271 | "tkMbLeave $tkPriv(inMenubutton)\n" |
4272 | "}\n" |
4273 | "set tkPriv(inMenubutton) $w\n" |
4274 | "if {[string compare [$w cget -state] \"disabled\"]} {\n" |
4275 | "$w configure -state active\n" |
4276 | "}\n" |
4277 | "}\n" |
4278 | "proc tkMbLeave w {\n" |
4279 | "global tkPriv\n" |
4280 | "set tkPriv(inMenubutton) {}\n" |
4281 | "if {![winfo exists $w]} {\n" |
4282 | "return\n" |
4283 | "}\n" |
4284 | "if {[string equal [$w cget -state] \"active\"]} {\n" |
4285 | "$w configure -state normal\n" |
4286 | "}\n" |
4287 | "}\n" |
4288 | "proc tkMbPost {w {x {}} {y {}}} {\n" |
4289 | "global tkPriv errorInfo\n" |
4290 | "global tcl_platform\n" |
4291 | "if {[string equal [$w cget -state] \"disabled\"] || \\\n" |
4292 | "\011 [string equal $w $tkPriv(postedMb)]} {\n" |
4293 | "return\n" |
4294 | "}\n" |
4295 | "set menu [$w cget -menu]\n" |
4296 | "if {[string equal $menu \"\"]} {\n" |
4297 | "return\n" |
4298 | "}\n" |
4299 | "set tearoff [expr {[string equal $tcl_platform(platform) \"unix\"] \\\n" |
4300 | "\011 || [string equal [$menu cget -type] \"tearoff\"]}]\n" |
4301 | "if {[string first $w $menu] != 0} {\n" |
4302 | "error \"can't post $menu: it isn't a descendant of $w (this is a new requirement in Tk versions 3.0 and later)\"\n" |
4303 | "}\n" |
4304 | "set cur $tkPriv(postedMb)\n" |
4305 | "if {[string compare $cur \"\"]} {\n" |
4306 | "tkMenuUnpost {}\n" |
4307 | "}\n" |
4308 | "set tkPriv(cursor) [$w cget -cursor]\n" |
4309 | "set tkPriv(relief) [$w cget -relief]\n" |
4310 | "$w configure -cursor arrow\n" |
4311 | "$w configure -relief raised\n" |
4312 | "set tkPriv(postedMb) $w\n" |
4313 | "set tkPriv(focus) [focus]\n" |
4314 | "$menu activate none\n" |
4315 | "tkGenerateMenuSelect $menu\n" |
4316 | "update idletasks\n" |
4317 | "if {[catch {\n" |
4318 | "switch [$w cget -direction] {\n" |
4319 | "above {\n" |
4320 | "set x [winfo rootx $w]\n" |
4321 | "set y [expr {[winfo rooty $w] - [winfo reqheight $menu]}]\n" |
4322 | "$menu post $x $y\n" |
4323 | "}\n" |
4324 | "below {\n" |
4325 | "set x [winfo rootx $w]\n" |
4326 | "set y [expr {[winfo rooty $w] + [winfo height $w]}]\n" |
4327 | "$menu post $x $y\n" |
4328 | "}\n" |
4329 | "left {\n" |
4330 | "set x [expr {[winfo rootx $w] - [winfo reqwidth $menu]}]\n" |
4331 | "set y [expr {(2 * [winfo rooty $w] + [winfo height $w]) / 2}]\n" |
4332 | "set entry [tkMenuFindName $menu [$w cget -text]]\n" |
4333 | "if {[$w cget -indicatoron]} {\n" |
4334 | "if {$entry == [$menu index last]} {\n" |
4335 | "incr y [expr {-([$menu yposition $entry] \\\n" |
4336 | "\011\011\011 \011+ [winfo reqheight $menu])/2}]\n" |
4337 | "} else {\n" |
4338 | "incr y [expr {-([$menu yposition $entry] \\\n" |
4339 | "\011\011\011 + [$menu yposition [expr {$entry+1}]])/2}]\n" |
4340 | "}\n" |
4341 | "}\n" |
4342 | "$menu post $x $y\n" |
4343 | "if {[string compare $entry {}] && [string compare [$menu entrycget $entry -state] \"disabled\"]} {\n" |
4344 | "$menu activate $entry\n" |
4345 | "tkGenerateMenuSelect $menu\n" |
4346 | "}\n" |
4347 | "}\n" |
4348 | "right {\n" |
4349 | "set x [expr {[winfo rootx $w] + [winfo width $w]}]\n" |
4350 | "set y [expr {(2 * [winfo rooty $w] + [winfo height $w]) / 2}]\n" |
4351 | "set entry [tkMenuFindName $menu [$w cget -text]]\n" |
4352 | "if {[$w cget -indicatoron]} {\n" |
4353 | "if {$entry == [$menu index last]} {\n" |
4354 | "incr y [expr {-([$menu yposition $entry] \\\n" |
4355 | "\011\011\011 \011+ [winfo reqheight $menu])/2}]\n" |
4356 | "} else {\n" |
4357 | "incr y [expr {-([$menu yposition $entry] \\\n" |
4358 | "\011\011\011 + [$menu yposition [expr {$entry+1}]])/2}]\n" |
4359 | "}\n" |
4360 | "}\n" |
4361 | "$menu post $x $y\n" |
4362 | "if {[string compare $entry {}] && [string compare [$menu entrycget $entry -state] \"disabled\"]} {\n" |
4363 | "$menu activate $entry\n" |
4364 | "tkGenerateMenuSelect $menu\n" |
4365 | "}\n" |
4366 | "}\n" |
4367 | "default {\n" |
4368 | "if {[$w cget -indicatoron]} {\n" |
4369 | "if {[string equal $y {}]} {\n" |
4370 | "set x [expr {[winfo rootx $w] + [winfo width $w]/2}]\n" |
4371 | "set y [expr {[winfo rooty $w] + [winfo height $w]/2}]\n" |
4372 | "}\n" |
4373 | "tkPostOverPoint $menu $x $y [tkMenuFindName $menu [$w cget -text]]\n" |
4374 | "} else {\n" |
4375 | "$menu post [winfo rootx $w] [expr {[winfo rooty $w]+[winfo height $w]}]\n" |
4376 | "} \n" |
4377 | "}\n" |
4378 | "}\n" |
4379 | "} msg]} {\n" |
4380 | "set savedInfo $errorInfo\n" |
4381 | "tkMenuUnpost {}\n" |
4382 | "error $msg $savedInfo\n" |
4383 | "}\n" |
4384 | "set tkPriv(tearoff) $tearoff\n" |
4385 | "if {$tearoff != 0} {\n" |
4386 | "focus $menu\n" |
4387 | "if {[winfo viewable $w]} {\n" |
4388 | "tkSaveGrabInfo $w\n" |
4389 | "grab -global $w\n" |
4390 | "}\n" |
4391 | "}\n" |
4392 | "}\n" |
4393 | "proc tkMenuUnpost menu {\n" |
4394 | "global tcl_platform\n" |
4395 | "global tkPriv\n" |
4396 | "set mb $tkPriv(postedMb)\n" |
4397 | "catch {focus $tkPriv(focus)}\n" |
4398 | "set tkPriv(focus) \"\"\n" |
4399 | "catch {\n" |
4400 | "if {[string compare $mb \"\"]} {\n" |
4401 | "set menu [$mb cget -menu]\n" |
4402 | "$menu unpost\n" |
4403 | "set tkPriv(postedMb) {}\n" |
4404 | "$mb configure -cursor $tkPriv(cursor)\n" |
4405 | "$mb configure -relief $tkPriv(relief)\n" |
4406 | "} elseif {[string compare $tkPriv(popup) \"\"]} {\n" |
4407 | "$tkPriv(popup) unpost\n" |
4408 | "set tkPriv(popup) {}\n" |
4409 | "} elseif {[string compare [$menu cget -type] \"menubar\"] \\\n" |
4410 | "\011\011&& [string compare [$menu cget -type] \"tearoff\"]} {\n" |
4411 | "while {1} {\n" |
4412 | "set parent [winfo parent $menu]\n" |
4413 | "if {[string compare [winfo class $parent] \"Menu\"] \\\n" |
4414 | "\011\011\011|| ![winfo ismapped $parent]} {\n" |
4415 | "break\n" |
4416 | "}\n" |
4417 | "$parent activate none\n" |
4418 | "$parent postcascade none\n" |
4419 | "tkGenerateMenuSelect $parent\n" |
4420 | "set type [$parent cget -type]\n" |
4421 | "if {[string equal $type \"menubar\"] || \\\n" |
4422 | "\011\011\011[string equal $type \"tearoff\"]} {\n" |
4423 | "break\n" |
4424 | "}\n" |
4425 | "set menu $parent\n" |
4426 | "}\n" |
4427 | "if {[string compare [$menu cget -type] \"menubar\"]} {\n" |
4428 | "$menu unpost\n" |
4429 | "}\n" |
4430 | "}\n" |
4431 | "}\n" |
4432 | "if {($tkPriv(tearoff) != 0) || [string compare $tkPriv(menuBar) \"\"]} {\n" |
4433 | "if {[string compare $menu \"\"]} {\n" |
4434 | "set grab [grab current $menu]\n" |
4435 | "if {[string compare $grab \"\"]} {\n" |
4436 | "grab release $grab\n" |
4437 | "}\n" |
4438 | "}\n" |
4439 | "tkRestoreOldGrab\n" |
4440 | "if {[string compare $tkPriv(menuBar) \"\"]} {\n" |
4441 | "$tkPriv(menuBar) configure -cursor $tkPriv(cursor)\n" |
4442 | "set tkPriv(menuBar) {}\n" |
4443 | "}\n" |
4444 | "if {[string compare $tcl_platform(platform) \"unix\"]} {\n" |
4445 | "set tkPriv(tearoff) 0\n" |
4446 | "}\n" |
4447 | "}\n" |
4448 | "}\n" |
4449 | "proc tkMbMotion {w upDown rootx rooty} {\n" |
4450 | "global tkPriv\n" |
4451 | "if {[string equal $tkPriv(inMenubutton) $w]} {\n" |
4452 | "return\n" |
4453 | "}\n" |
4454 | "set new [winfo containing $rootx $rooty]\n" |
4455 | "if {[string compare $new $tkPriv(inMenubutton)] \\\n" |
4456 | "\011 && ([string equal $new \"\"] \\\n" |
4457 | "\011 || [string equal [winfo toplevel $new] [winfo toplevel $w]])} {\n" |
4458 | "if {[string compare $tkPriv(inMenubutton) \"\"]} {\n" |
4459 | "tkMbLeave $tkPriv(inMenubutton)\n" |
4460 | "}\n" |
4461 | "if {[string compare $new \"\"] \\\n" |
4462 | "\011\011&& [string equal [winfo class $new] \"Menubutton\"] \\\n" |
4463 | "\011\011&& ([$new cget -indicatoron] == 0) \\\n" |
4464 | "\011\011&& ([$w cget -indicatoron] == 0)} {\n" |
4465 | "if {[string equal $upDown \"down\"]} {\n" |
4466 | "tkMbPost $new $rootx $rooty\n" |
4467 | "} else {\n" |
4468 | "tkMbEnter $new\n" |
4469 | "}\n" |
4470 | "}\n" |
4471 | "}\n" |
4472 | "}\n" |
4473 | "proc tkMbButtonUp w {\n" |
4474 | "global tkPriv\n" |
4475 | "global tcl_platform\n" |
4476 | "set menu [$w cget -menu]\n" |
4477 | "set tearoff [expr {[string equal $tcl_platform(platform) \"unix\"] || \\\n" |
4478 | "\011 ([string compare $menu {}] && \\\n" |
4479 | "\011 [string equal [$menu cget -type] \"tearoff\"])}]\n" |
4480 | "if {($tearoff != 0) && [string equal $tkPriv(postedMb) $w] \\\n" |
4481 | "\011 && [string equal $tkPriv(inMenubutton) $w]} {\n" |
4482 | "tkMenuFirstEntry [$tkPriv(postedMb) cget -menu]\n" |
4483 | "} else {\n" |
4484 | "tkMenuUnpost {}\n" |
4485 | "}\n" |
4486 | "}\n" |
4487 | "proc tkMenuMotion {menu x y state} {\n" |
4488 | "global tkPriv\n" |
4489 | "if {[string equal $menu $tkPriv(window)]} {\n" |
4490 | "if {[string equal [$menu cget -type] \"menubar\"]} {\n" |
4491 | "if {[info exists tkPriv(focus)] && \\\n" |
4492 | "\011\011 [string compare $menu $tkPriv(focus)]} {\n" |
4493 | "$menu activate @$x,$y\n" |
4494 | "tkGenerateMenuSelect $menu\n" |
4495 | "}\n" |
4496 | "} else {\n" |
4497 | "$menu activate @$x,$y\n" |
4498 | "tkGenerateMenuSelect $menu\n" |
4499 | "}\n" |
4500 | "}\n" |
4501 | "if {($state & 0x1f00) != 0} {\n" |
4502 | "$menu postcascade active\n" |
4503 | "}\n" |
4504 | "}\n" |
4505 | "proc tkMenuButtonDown menu {\n" |
4506 | "global tkPriv\n" |
4507 | "global tcl_platform\n" |
4508 | "if {![winfo viewable $menu]} {\n" |
4509 | "return\n" |
4510 | "}\n" |
4511 | "$menu postcascade active\n" |
4512 | "if {[string compare $tkPriv(postedMb) \"\"] && \\\n" |
4513 | "\011 [winfo viewable $tkPriv(postedMb)]} {\n" |
4514 | "grab -global $tkPriv(postedMb)\n" |
4515 | "} else {\n" |
4516 | "while {[string equal [$menu cget -type] \"normal\"] \\\n" |
4517 | "\011\011&& [string equal [winfo class [winfo parent $menu]] \"Menu\"] \\\n" |
4518 | "\011\011&& [winfo ismapped [winfo parent $menu]]} {\n" |
4519 | "set menu [winfo parent $menu]\n" |
4520 | "}\n" |
4521 | "if {[string equal $tkPriv(menuBar) {}]} {\n" |
4522 | "set tkPriv(menuBar) $menu\n" |
4523 | "set tkPriv(cursor) [$menu cget -cursor]\n" |
4524 | "$menu configure -cursor arrow\n" |
4525 | "}\n" |
4526 | "if {[string compare $menu [grab current $menu]]} {\n" |
4527 | "tkSaveGrabInfo $menu\n" |
4528 | "}\n" |
4529 | "if {[string equal $tcl_platform(platform) \"unix\"]} {\n" |
4530 | "grab -global $menu\n" |
4531 | "}\n" |
4532 | "}\n" |
4533 | "}\n" |
4534 | "proc tkMenuLeave {menu rootx rooty state} {\n" |
4535 | "global tkPriv\n" |
4536 | "set tkPriv(window) {}\n" |
4537 | "if {[string equal [$menu index active] \"none\"]} {\n" |
4538 | "return\n" |
4539 | "}\n" |
4540 | "if {[string equal [$menu type active] \"cascade\"]\n" |
4541 | "&& [string equal [winfo containing $rootx $rooty] \\\n" |
4542 | " [$menu entrycget active -menu]]} {\n" |
4543 | "return\n" |
4544 | "}\n" |
4545 | "$menu activate none\n" |
4546 | "tkGenerateMenuSelect $menu\n" |
4547 | "}\n" |
4548 | "proc tkMenuInvoke {w buttonRelease} {\n" |
4549 | "global tkPriv\n" |
4550 | "if {$buttonRelease && [string equal $tkPriv(window) {}]} {\n" |
4551 | "$w postcascade none\n" |
4552 | "$w activate none\n" |
4553 | "event generate $w <<MenuSelect>>\n" |
4554 | "tkMenuUnpost $w\n" |
4555 | "return\n" |
4556 | "}\n" |
4557 | "if {[string equal [$w type active] \"cascade\"]} {\n" |
4558 | "$w postcascade active\n" |
4559 | "set menu [$w entrycget active -menu]\n" |
4560 | "tkMenuFirstEntry $menu\n" |
4561 | "} elseif {[string equal [$w type active] \"tearoff\"]} {\n" |
4562 | "tkTearOffMenu $w\n" |
4563 | "tkMenuUnpost $w\n" |
4564 | "} elseif {[string equal [$w cget -type] \"menubar\"]} {\n" |
4565 | "$w postcascade none\n" |
4566 | "set active [$w index active]\n" |
4567 | "set isCascade [string equal [$w type $active] \"cascade\"]\n" |
4568 | "if { $isCascade } {\n" |
4569 | "$w activate none\n" |
4570 | "event generate $w <<MenuSelect>>\n" |
4571 | "}\n" |
4572 | "tkMenuUnpost $w\n" |
4573 | "if { !$isCascade } {\n" |
4574 | "uplevel #0 [list $w invoke $active]\n" |
4575 | "}\n" |
4576 | "} else {\n" |
4577 | "tkMenuUnpost $w\n" |
4578 | "uplevel #0 [list $w invoke active]\n" |
4579 | "}\n" |
4580 | "}\n" |
4581 | "proc tkMenuEscape menu {\n" |
4582 | "set parent [winfo parent $menu]\n" |
4583 | "if {[string compare [winfo class $parent] \"Menu\"]} {\n" |
4584 | "tkMenuUnpost $menu\n" |
4585 | "} elseif {[string equal [$parent cget -type] \"menubar\"]} {\n" |
4586 | "tkMenuUnpost $menu\n" |
4587 | "tkRestoreOldGrab\n" |
4588 | "} else {\n" |
4589 | "tkMenuNextMenu $menu left\n" |
4590 | "}\n" |
4591 | "}\n" |
4592 | "proc tkMenuUpArrow {menu} {\n" |
4593 | "if {[string equal [$menu cget -type] \"menubar\"]} {\n" |
4594 | "tkMenuNextMenu $menu left\n" |
4595 | "} else {\n" |
4596 | "tkMenuNextEntry $menu -1\n" |
4597 | "}\n" |
4598 | "}\n" |
4599 | "proc tkMenuDownArrow {menu} {\n" |
4600 | "if {[string equal [$menu cget -type] \"menubar\"]} {\n" |
4601 | "tkMenuNextMenu $menu right\n" |
4602 | "} else {\n" |
4603 | "tkMenuNextEntry $menu 1\n" |
4604 | "}\n" |
4605 | "}\n" |
4606 | "proc tkMenuLeftArrow {menu} {\n" |
4607 | "if {[string equal [$menu cget -type] \"menubar\"]} {\n" |
4608 | "tkMenuNextEntry $menu -1\n" |
4609 | "} else {\n" |
4610 | "tkMenuNextMenu $menu left\n" |
4611 | "}\n" |
4612 | "}\n" |
4613 | "proc tkMenuRightArrow {menu} {\n" |
4614 | "if {[string equal [$menu cget -type] \"menubar\"]} {\n" |
4615 | "tkMenuNextEntry $menu 1\n" |
4616 | "} else {\n" |
4617 | "tkMenuNextMenu $menu right\n" |
4618 | "}\n" |
4619 | "}\n" |
4620 | "proc tkMenuNextMenu {menu direction} {\n" |
4621 | "global tkPriv\n" |
4622 | "if {[string equal $direction \"right\"]} {\n" |
4623 | "set count 1\n" |
4624 | "set parent [winfo parent $menu]\n" |
4625 | "set class [winfo class $parent]\n" |
4626 | "if {[string equal [$menu type active] \"cascade\"]} {\n" |
4627 | "$menu postcascade active\n" |
4628 | "set m2 [$menu entrycget active -menu]\n" |
4629 | "if {[string compare $m2 \"\"]} {\n" |
4630 | "tkMenuFirstEntry $m2\n" |
4631 | "}\n" |
4632 | "return\n" |
4633 | "} else {\n" |
4634 | "set parent [winfo parent $menu]\n" |
4635 | "while {[string compare $parent \".\"]} {\n" |
4636 | "if {[string equal [winfo class $parent] \"Menu\"] \\\n" |
4637 | "\011\011\011&& [string equal [$parent cget -type] \"menubar\"]} {\n" |
4638 | "tk_menuSetFocus $parent\n" |
4639 | "tkMenuNextEntry $parent 1\n" |
4640 | "return\n" |
4641 | "}\n" |
4642 | "set parent [winfo parent $parent]\n" |
4643 | "}\n" |
4644 | "}\n" |
4645 | "} else {\n" |
4646 | "set count -1\n" |
4647 | "set m2 [winfo parent $menu]\n" |
4648 | "if {[string equal [winfo class $m2] \"Menu\"]} {\n" |
4649 | "if {[string compare [$m2 cget -type] \"menubar\"]} {\n" |
4650 | "$menu activate none\n" |
4651 | "tkGenerateMenuSelect $menu\n" |
4652 | "tk_menuSetFocus $m2\n" |
4653 | "set tmp [$m2 index active]\n" |
4654 | "$m2 activate none\n" |
4655 | "$m2 activate $tmp\n" |
4656 | "return\n" |
4657 | "}\n" |
4658 | "}\n" |
4659 | "}\n" |
4660 | "set m2 [winfo parent $menu]\n" |
4661 | "if {[string equal [winfo class $m2] \"Menu\"]} {\n" |
4662 | "if {[string equal [$m2 cget -type] \"menubar\"]} {\n" |
4663 | "tk_menuSetFocus $m2\n" |
4664 | "tkMenuNextEntry $m2 -1\n" |
4665 | "return\n" |
4666 | "}\n" |
4667 | "}\n" |
4668 | "set w $tkPriv(postedMb)\n" |
4669 | "if {[string equal $w \"\"]} {\n" |
4670 | "return\n" |
4671 | "}\n" |
4672 | "set buttons [winfo children [winfo parent $w]]\n" |
4673 | "set length [llength $buttons]\n" |
4674 | "set i [expr {[lsearch -exact $buttons $w] + $count}]\n" |
4675 | "while {1} {\n" |
4676 | "while {$i < 0} {\n" |
4677 | "incr i $length\n" |
4678 | "}\n" |
4679 | "while {$i >= $length} {\n" |
4680 | "incr i -$length\n" |
4681 | "}\n" |
4682 | "set mb [lindex $buttons $i]\n" |
4683 | "if {[string equal [winfo class $mb] \"Menubutton\"] \\\n" |
4684 | "\011\011&& [string compare [$mb cget -state] \"disabled\"] \\\n" |
4685 | "\011\011&& [string compare [$mb cget -menu] \"\"] \\\n" |
4686 | "\011\011&& [string compare [[$mb cget -menu] index last] \"none\"]} {\n" |
4687 | "break\n" |
4688 | "}\n" |
4689 | "if {[string equal $mb $w]} {\n" |
4690 | "return\n" |
4691 | "}\n" |
4692 | "incr i $count\n" |
4693 | "}\n" |
4694 | "tkMbPost $mb\n" |
4695 | "tkMenuFirstEntry [$mb cget -menu]\n" |
4696 | "}\n" |
4697 | "proc tkMenuNextEntry {menu count} {\n" |
4698 | "global tkPriv\n" |
4699 | "if {[string equal [$menu index last] \"none\"]} {\n" |
4700 | "return\n" |
4701 | "}\n" |
4702 | "set length [expr {[$menu index last]+1}]\n" |
4703 | "set quitAfter $length\n" |
4704 | "set active [$menu index active]\n" |
4705 | "if {[string equal $active \"none\"]} {\n" |
4706 | "set i 0\n" |
4707 | "} else {\n" |
4708 | "set i [expr {$active + $count}]\n" |
4709 | "}\n" |
4710 | "while {1} {\n" |
4711 | "if {$quitAfter <= 0} {\n" |
4712 | "return\n" |
4713 | "}\n" |
4714 | "while {$i < 0} {\n" |
4715 | "incr i $length\n" |
4716 | "}\n" |
4717 | "while {$i >= $length} {\n" |
4718 | "incr i -$length\n" |
4719 | "}\n" |
4720 | "if {[catch {$menu entrycget $i -state} state] == 0} {\n" |
4721 | "if {[string compare $state \"disabled\"]} {\n" |
4722 | "break\n" |
4723 | "}\n" |
4724 | "}\n" |
4725 | "if {$i == $active} {\n" |
4726 | "return\n" |
4727 | "}\n" |
4728 | "incr i $count\n" |
4729 | "incr quitAfter -1\n" |
4730 | "}\n" |
4731 | "$menu activate $i\n" |
4732 | "tkGenerateMenuSelect $menu\n" |
4733 | "if {[string equal [$menu type $i] \"cascade\"]} {\n" |
4734 | "set cascade [$menu entrycget $i -menu]\n" |
4735 | "if {[string compare $cascade \"\"]} {\n" |
4736 | "$menu postcascade $i\n" |
4737 | "tkMenuFirstEntry $cascade\n" |
4738 | "}\n" |
4739 | "}\n" |
4740 | "}\n" |
4741 | "proc tkMenuFind {w char} {\n" |
4742 | "global tkPriv\n" |
4743 | "set char [string tolower $char]\n" |
4744 | "set windowlist [winfo child $w]\n" |
4745 | "foreach child $windowlist {\n" |
4746 | "if {[string compare [winfo toplevel [focus]] \\\n" |
4747 | "\011\011[winfo toplevel $child]]} {\n" |
4748 | "continue\n" |
4749 | "}\n" |
4750 | "if {[string equal [winfo class $child] \"Menu\"] && \\\n" |
4751 | "\011\011[string equal [$child cget -type] \"menubar\"]} {\n" |
4752 | "if {[string equal $char \"\"]} {\n" |
4753 | "return $child\n" |
4754 | "}\n" |
4755 | "set last [$child index last]\n" |
4756 | "for {set i [$child cget -tearoff]} {$i <= $last} {incr i} {\n" |
4757 | "if {[string equal [$child type $i] \"separator\"]} {\n" |
4758 | "continue\n" |
4759 | "}\n" |
4760 | "set char2 [string index [$child entrycget $i -label] \\\n" |
4761 | "\011\011\011[$child entrycget $i -underline]]\n" |
4762 | "if {[string equal $char [string tolower $char2]] \\\n" |
4763 | "\011\011\011|| [string equal $char \"\"]} {\n" |
4764 | "if {[string compare [$child entrycget $i -state] \"disabled\"]} {\n" |
4765 | "return $child\n" |
4766 | "}\n" |
4767 | "}\n" |
4768 | "}\n" |
4769 | "}\n" |
4770 | "}\n" |
4771 | "foreach child $windowlist {\n" |
4772 | "if {[string compare [winfo toplevel [focus]] \\\n" |
4773 | "\011\011[winfo toplevel $child]]} {\n" |
4774 | "continue\n" |
4775 | "}\n" |
4776 | "switch [winfo class $child] {\n" |
4777 | "Menubutton {\n" |
4778 | "set char2 [string index [$child cget -text] \\\n" |
4779 | "\011\011\011[$child cget -underline]]\n" |
4780 | "if {[string equal $char [string tolower $char2]] \\\n" |
4781 | "\011\011\011|| [string equal $char \"\"]} {\n" |
4782 | "if {[string compare [$child cget -state] \"disabled\"]} {\n" |
4783 | "return $child\n" |
4784 | "}\n" |
4785 | "}\n" |
4786 | "}\n" |
4787 | "default {\n" |
4788 | "set match [tkMenuFind $child $char]\n" |
4789 | "if {[string compare $match \"\"]} {\n" |
4790 | "return $match\n" |
4791 | "}\n" |
4792 | "}\n" |
4793 | "}\n" |
4794 | "}\n" |
4795 | "return {}\n" |
4796 | "}\n" |
4797 | "proc tkTraverseToMenu {w char} {\n" |
4798 | "global tkPriv\n" |
4799 | "if {[string equal $char \"\"]} {\n" |
4800 | "return\n" |
4801 | "}\n" |
4802 | "while {[string equal [winfo class $w] \"Menu\"]} {\n" |
4803 | "if {[string compare [$w cget -type] \"menubar\"] \\\n" |
4804 | "\011\011&& [string equal $tkPriv(postedMb) \"\"]} {\n" |
4805 | "return\n" |
4806 | "}\n" |
4807 | "if {[string equal [$w cget -type] \"menubar\"]} {\n" |
4808 | "break\n" |
4809 | "}\n" |
4810 | "set w [winfo parent $w]\n" |
4811 | "}\n" |
4812 | "set w [tkMenuFind [winfo toplevel $w] $char]\n" |
4813 | "if {[string compare $w \"\"]} {\n" |
4814 | "if {[string equal [winfo class $w] \"Menu\"]} {\n" |
4815 | "tk_menuSetFocus $w\n" |
4816 | "set tkPriv(window) $w\n" |
4817 | "tkSaveGrabInfo $w\n" |
4818 | "grab -global $w\n" |
4819 | "tkTraverseWithinMenu $w $char\n" |
4820 | "} else {\n" |
4821 | "tkMbPost $w\n" |
4822 | "tkMenuFirstEntry [$w cget -menu]\n" |
4823 | "}\n" |
4824 | "}\n" |
4825 | "}\n" |
4826 | "proc tkFirstMenu w {\n" |
4827 | "set w [tkMenuFind [winfo toplevel $w] \"\"]\n" |
4828 | "if {[string compare $w \"\"]} {\n" |
4829 | "if {[string equal [winfo class $w] \"Menu\"]} {\n" |
4830 | "tk_menuSetFocus $w\n" |
4831 | "set tkPriv(window) $w\n" |
4832 | "tkSaveGrabInfo $w\n" |
4833 | "grab -global $w\n" |
4834 | "tkMenuFirstEntry $w\n" |
4835 | "} else {\n" |
4836 | "tkMbPost $w\n" |
4837 | "tkMenuFirstEntry [$w cget -menu]\n" |
4838 | "}\n" |
4839 | "}\n" |
4840 | "}\n" |
4841 | "proc tkTraverseWithinMenu {w char} {\n" |
4842 | "if {[string equal $char \"\"]} {\n" |
4843 | "return\n" |
4844 | "}\n" |
4845 | "set char [string tolower $char]\n" |
4846 | "set last [$w index last]\n" |
4847 | "if {[string equal $last \"none\"]} {\n" |
4848 | "return\n" |
4849 | "}\n" |
4850 | "for {set i 0} {$i <= $last} {incr i} {\n" |
4851 | "if {[catch {set char2 [string index \\\n" |
4852 | "\011\011[$w entrycget $i -label] [$w entrycget $i -underline]]}]} {\n" |
4853 | "continue\n" |
4854 | "}\n" |
4855 | "if {[string equal $char [string tolower $char2]]} {\n" |
4856 | "if {[string equal [$w type $i] \"cascade\"]} {\n" |
4857 | "$w activate $i\n" |
4858 | "$w postcascade active\n" |
4859 | "event generate $w <<MenuSelect>>\n" |
4860 | "set m2 [$w entrycget $i -menu]\n" |
4861 | "if {[string compare $m2 \"\"]} {\n" |
4862 | "tkMenuFirstEntry $m2\n" |
4863 | "}\n" |
4864 | "} else {\n" |
4865 | "tkMenuUnpost $w\n" |
4866 | "uplevel #0 [list $w invoke $i]\n" |
4867 | "}\n" |
4868 | "return\n" |
4869 | "}\n" |
4870 | "}\n" |
4871 | "}\n" |
4872 | "proc tkMenuFirstEntry menu {\n" |
4873 | "if {[string equal $menu \"\"]} {\n" |
4874 | "return\n" |
4875 | "}\n" |
4876 | "tk_menuSetFocus $menu\n" |
4877 | "if {[string compare [$menu index active] \"none\"]} {\n" |
4878 | "return\n" |
4879 | "}\n" |
4880 | "set last [$menu index last]\n" |
4881 | "if {[string equal $last \"none\"]} {\n" |
4882 | "return\n" |
4883 | "}\n" |
4884 | "for {set i 0} {$i <= $last} {incr i} {\n" |
4885 | "if {([catch {set state [$menu entrycget $i -state]}] == 0) \\\n" |
4886 | "\011\011&& [string compare $state \"disabled\"] \\\n" |
4887 | "\011\011&& [string compare [$menu type $i] \"tearoff\"]} {\n" |
4888 | "$menu activate $i\n" |
4889 | "tkGenerateMenuSelect $menu\n" |
4890 | "if {[string equal [$menu type $i] \"cascade\"] && \\\n" |
4891 | "\011\011[string equal [$menu cget -type] \"menubar\"]} {\n" |
4892 | "set cascade [$menu entrycget $i -menu]\n" |
4893 | "if {[string compare $cascade \"\"]} {\n" |
4894 | "$menu postcascade $i\n" |
4895 | "tkMenuFirstEntry $cascade\n" |
4896 | "}\n" |
4897 | "}\n" |
4898 | "return\n" |
4899 | "}\n" |
4900 | "}\n" |
4901 | "}\n" |
4902 | "proc tkMenuFindName {menu s} {\n" |
4903 | "set i \"\"\n" |
4904 | "if {![regexp {^active$|^last$|^none$|^[0-9]|^@} $s]} {\n" |
4905 | "catch {set i [$menu index $s]}\n" |
4906 | "return $i\n" |
4907 | "}\n" |
4908 | "set last [$menu index last]\n" |
4909 | "if {[string equal $last \"none\"]} {\n" |
4910 | "return\n" |
4911 | "}\n" |
4912 | "for {set i 0} {$i <= $last} {incr i} {\n" |
4913 | "if {![catch {$menu entrycget $i -label} label]} {\n" |
4914 | "if {[string equal $label $s]} {\n" |
4915 | "return $i\n" |
4916 | "}\n" |
4917 | "}\n" |
4918 | "}\n" |
4919 | "return \"\"\n" |
4920 | "}\n" |
4921 | "proc tkPostOverPoint {menu x y {entry {}}} {\n" |
4922 | "global tcl_platform\n" |
4923 | "if {[string compare $entry {}]} {\n" |
4924 | "if {$entry == [$menu index last]} {\n" |
4925 | "incr y [expr {-([$menu yposition $entry] \\\n" |
4926 | "\011\011 + [winfo reqheight $menu])/2}]\n" |
4927 | "} else {\n" |
4928 | "incr y [expr {-([$menu yposition $entry] \\\n" |
4929 | "\011\011 + [$menu yposition [expr {$entry+1}]])/2}]\n" |
4930 | "}\n" |
4931 | "incr x [expr {-[winfo reqwidth $menu]/2}]\n" |
4932 | "}\n" |
4933 | "$menu post $x $y\n" |
4934 | "if {[string compare $entry {}] \\\n" |
4935 | "\011 && [string compare [$menu entrycget $entry -state] \"disabled\"]} {\n" |
4936 | "$menu activate $entry\n" |
4937 | "tkGenerateMenuSelect $menu\n" |
4938 | "}\n" |
4939 | "}\n" |
4940 | "proc tkSaveGrabInfo w {\n" |
4941 | "global tkPriv\n" |
4942 | "set tkPriv(oldGrab) [grab current $w]\n" |
4943 | "if {[string compare $tkPriv(oldGrab) \"\"]} {\n" |
4944 | "set tkPriv(grabStatus) [grab status $tkPriv(oldGrab)]\n" |
4945 | "}\n" |
4946 | "}\n" |
4947 | "proc tkRestoreOldGrab {} {\n" |
4948 | "global tkPriv\n" |
4949 | "if {[string compare $tkPriv(oldGrab) \"\"]} {\n" |
4950 | "catch {\n" |
4951 | "if {[string equal $tkPriv(grabStatus) \"global\"]} {\n" |
4952 | "grab set -global $tkPriv(oldGrab)\n" |
4953 | "} else {\n" |
4954 | "grab set $tkPriv(oldGrab)\n" |
4955 | "}\n" |
4956 | "}\n" |
4957 | "set tkPriv(oldGrab) \"\"\n" |
4958 | "}\n" |
4959 | "}\n" |
4960 | "proc tk_menuSetFocus {menu} {\n" |
4961 | "global tkPriv\n" |
4962 | "if {![info exists tkPriv(focus)] || [string equal $tkPriv(focus) {}]} {\n" |
4963 | "set tkPriv(focus) [focus]\n" |
4964 | "}\n" |
4965 | "focus $menu\n" |
4966 | "}\n" |
4967 | "proc tkGenerateMenuSelect {menu} {\n" |
4968 | "global tkPriv\n" |
4969 | "if {[string equal $tkPriv(activeMenu) $menu] \\\n" |
4970 | " && [string equal $tkPriv(activeItem) [$menu index active]]} {\n" |
4971 | "return\n" |
4972 | "}\n" |
4973 | "set tkPriv(activeMenu) $menu\n" |
4974 | "set tkPriv(activeItem) [$menu index active]\n" |
4975 | "event generate $menu <<MenuSelect>>\n" |
4976 | "}\n" |
4977 | "proc tk_popup {menu x y {entry {}}} {\n" |
4978 | "global tkPriv\n" |
4979 | "global tcl_platform\n" |
4980 | "if {[string compare $tkPriv(popup) \"\"] \\\n" |
4981 | "\011 || [string compare $tkPriv(postedMb) \"\"]} {\n" |
4982 | "tkMenuUnpost {}\n" |
4983 | "}\n" |
4984 | "tkPostOverPoint $menu $x $y $entry\n" |
4985 | "if {[string equal $tcl_platform(platform) \"unix\"] \\\n" |
4986 | "\011 && [winfo viewable $menu]} {\n" |
4987 | "tkSaveGrabInfo $menu\n" |
4988 | "grab -global $menu\n" |
4989 | "set tkPriv(popup) $menu\n" |
4990 | "tk_menuSetFocus $menu\n" |
4991 | "}\n" |
4992 | "}\n" |
4993 | ; |
4994 | static char Et_zFile18[] = |
4995 | "namespace eval ::tk::dialog {}\n" |
4996 | "image create bitmap ::tk::dialog::b1 -foreground black \\\n" |
4997 | "-data \"#define b1_width 32\\n#define b1_height 32\n" |
4998 | "static unsigned char q1_bits[] = {\n" |
4999 | "0x00, 0xf8, 0x1f, 0x00, 0x00, 0x07, 0xe0, 0x00, 0xc0, 0x00, 0x00, 0x03,\n" |
5000 | "0x20, 0x00, 0x00, 0x04, 0x10, 0x00, 0x00, 0x08, 0x08, 0x00, 0x00, 0x10,\n" |
5001 | "0x04, 0x00, 0x00, 0x20, 0x02, 0x00, 0x00, 0x40, 0x02, 0x00, 0x00, 0x40,\n" |
5002 | "0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80,\n" |
5003 | "0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80,\n" |
5004 | "0x01, 0x00, 0x00, 0x80, 0x02, 0x00, 0x00, 0x40, 0x02, 0x00, 0x00, 0x40,\n" |
5005 | "0x04, 0x00, 0x00, 0x20, 0x08, 0x00, 0x00, 0x10, 0x10, 0x00, 0x00, 0x08,\n" |
5006 | "0x60, 0x00, 0x00, 0x04, 0x80, 0x03, 0x80, 0x03, 0x00, 0x0c, 0x78, 0x00,\n" |
5007 | "0x00, 0x30, 0x04, 0x00, 0x00, 0x40, 0x04, 0x00, 0x00, 0x40, 0x04, 0x00,\n" |
5008 | "0x00, 0x80, 0x04, 0x00, 0x00, 0x00, 0x05, 0x00, 0x00, 0x00, 0x06, 0x00,\n" |
5009 | "0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};\"\n" |
5010 | "image create bitmap ::tk::dialog::b2 -foreground white \\\n" |
5011 | "-data \"#define b2_width 32\\n#define b2_height 32\n" |
5012 | "static unsigned char b2_bits[] = {\n" |
5013 | "0x00, 0x00, 0x00, 0x00, 0x00, 0xf8, 0x1f, 0x00, 0x00, 0xff, 0xff, 0x00,\n" |
5014 | "0xc0, 0xff, 0xff, 0x03, 0xe0, 0xff, 0xff, 0x07, 0xf0, 0xff, 0xff, 0x0f,\n" |
5015 | "0xf8, 0xff, 0xff, 0x1f, 0xfc, 0xff, 0xff, 0x3f, 0xfc, 0xff, 0xff, 0x3f,\n" |
5016 | "0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f,\n" |
5017 | "0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f,\n" |
5018 | "0xfe, 0xff, 0xff, 0x7f, 0xfc, 0xff, 0xff, 0x3f, 0xfc, 0xff, 0xff, 0x3f,\n" |
5019 | "0xf8, 0xff, 0xff, 0x1f, 0xf0, 0xff, 0xff, 0x0f, 0xe0, 0xff, 0xff, 0x07,\n" |
5020 | "0x80, 0xff, 0xff, 0x03, 0x00, 0xfc, 0x7f, 0x00, 0x00, 0xf0, 0x07, 0x00,\n" |
5021 | "0x00, 0xc0, 0x03, 0x00, 0x00, 0x80, 0x03, 0x00, 0x00, 0x80, 0x03, 0x00,\n" |
5022 | "0x00, 0x00, 0x03, 0x00, 0x00, 0x00, 0x02, 0x00, 0x00, 0x00, 0x00, 0x00,\n" |
5023 | "0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};\"\n" |
5024 | "image create bitmap ::tk::dialog::q -foreground blue \\\n" |
5025 | "-data \"#define q_width 32\\n#define q_height 32\n" |
5026 | "static unsigned char q_bits[] = {\n" |
5027 | "0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,\n" |
5028 | "0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xe0, 0x07, 0x00,\n" |
5029 | "0x00, 0x10, 0x0f, 0x00, 0x00, 0x18, 0x1e, 0x00, 0x00, 0x38, 0x1e, 0x00,\n" |
5030 | "0x00, 0x38, 0x1e, 0x00, 0x00, 0x10, 0x0f, 0x00, 0x00, 0x80, 0x07, 0x00,\n" |
5031 | "0x00, 0xc0, 0x01, 0x00, 0x00, 0xc0, 0x00, 0x00, 0x00, 0xc0, 0x00, 0x00,\n" |
5032 | "0x00, 0x00, 0x00, 0x00, 0x00, 0xc0, 0x00, 0x00, 0x00, 0xe0, 0x01, 0x00,\n" |
5033 | "0x00, 0xe0, 0x01, 0x00, 0x00, 0xc0, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,\n" |
5034 | "0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,\n" |
5035 | "0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,\n" |
5036 | "0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,\n" |
5037 | "0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};\"\n" |
5038 | "image create bitmap ::tk::dialog::i -foreground blue \\\n" |
5039 | "-data \"#define i_width 32\\n#define i_height 32\n" |
5040 | "static unsigned char i_bits[] = {\n" |
5041 | "0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,\n" |
5042 | "0x00, 0xe0, 0x01, 0x00, 0x00, 0xf0, 0x03, 0x00, 0x00, 0xf0, 0x03, 0x00,\n" |
5043 | "0x00, 0xe0, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,\n" |
5044 | "0x00, 0xf8, 0x03, 0x00, 0x00, 0xf0, 0x03, 0x00, 0x00, 0xe0, 0x03, 0x00,\n" |
5045 | "0x00, 0xe0, 0x03, 0x00, 0x00, 0xe0, 0x03, 0x00, 0x00, 0xe0, 0x03, 0x00,\n" |
5046 | "0x00, 0xe0, 0x03, 0x00, 0x00, 0xe0, 0x03, 0x00, 0x00, 0xf0, 0x07, 0x00,\n" |
5047 | "0x00, 0xf8, 0x0f, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,\n" |
5048 | "0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,\n" |
5049 | "0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,\n" |
5050 | "0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,\n" |
5051 | "0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};\"\n" |
5052 | "image create bitmap ::tk::dialog::w1 -foreground black \\\n" |
5053 | "-data \"#define w1_width 32\\n#define w1_height 32\n" |
5054 | "static unsigned char w1_bits[] = {\n" |
5055 | "0x00, 0x80, 0x01, 0x00, 0x00, 0x40, 0x02, 0x00, 0x00, 0x20, 0x04, 0x00,\n" |
5056 | "0x00, 0x10, 0x04, 0x00, 0x00, 0x10, 0x08, 0x00, 0x00, 0x08, 0x08, 0x00,\n" |
5057 | "0x00, 0x08, 0x10, 0x00, 0x00, 0x04, 0x10, 0x00, 0x00, 0x04, 0x20, 0x00,\n" |
5058 | "0x00, 0x02, 0x20, 0x00, 0x00, 0x02, 0x40, 0x00, 0x00, 0x01, 0x40, 0x00,\n" |
5059 | "0x00, 0x01, 0x80, 0x00, 0x80, 0x00, 0x80, 0x00, 0x80, 0x00, 0x00, 0x01,\n" |
5060 | "0x40, 0x00, 0x00, 0x01, 0x40, 0x00, 0x00, 0x02, 0x20, 0x00, 0x00, 0x02,\n" |
5061 | "0x20, 0x00, 0x00, 0x04, 0x10, 0x00, 0x00, 0x04, 0x10, 0x00, 0x00, 0x08,\n" |
5062 | "0x08, 0x00, 0x00, 0x08, 0x08, 0x00, 0x00, 0x10, 0x04, 0x00, 0x00, 0x10,\n" |
5063 | "0x04, 0x00, 0x00, 0x20, 0x02, 0x00, 0x00, 0x20, 0x01, 0x00, 0x00, 0x40,\n" |
5064 | "0x01, 0x00, 0x00, 0x40, 0x01, 0x00, 0x00, 0x40, 0x02, 0x00, 0x00, 0x20,\n" |
5065 | "0xfc, 0xff, 0xff, 0x1f, 0x00, 0x00, 0x00, 0x00};\"\n" |
5066 | "image create bitmap ::tk::dialog::w2 -foreground yellow \\\n" |
5067 | "-data \"#define w2_width 32\\n#define w2_height 32\n" |
5068 | "static unsigned char w2_bits[] = {\n" |
5069 | "0x00, 0x00, 0x00, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0xc0, 0x03, 0x00,\n" |
5070 | "0x00, 0xe0, 0x03, 0x00, 0x00, 0xe0, 0x07, 0x00, 0x00, 0xf0, 0x07, 0x00,\n" |
5071 | "0x00, 0xf0, 0x0f, 0x00, 0x00, 0xf8, 0x0f, 0x00, 0x00, 0xf8, 0x1f, 0x00,\n" |
5072 | "0x00, 0xfc, 0x1f, 0x00, 0x00, 0xfc, 0x3f, 0x00, 0x00, 0xfe, 0x3f, 0x00,\n" |
5073 | "0x00, 0xfe, 0x7f, 0x00, 0x00, 0xff, 0x7f, 0x00, 0x00, 0xff, 0xff, 0x00,\n" |
5074 | "0x80, 0xff, 0xff, 0x00, 0x80, 0xff, 0xff, 0x01, 0xc0, 0xff, 0xff, 0x01,\n" |
5075 | "0xc0, 0xff, 0xff, 0x03, 0xe0, 0xff, 0xff, 0x03, 0xe0, 0xff, 0xff, 0x07,\n" |
5076 | "0xf0, 0xff, 0xff, 0x07, 0xf0, 0xff, 0xff, 0x0f, 0xf8, 0xff, 0xff, 0x0f,\n" |
5077 | "0xf8, 0xff, 0xff, 0x1f, 0xfc, 0xff, 0xff, 0x1f, 0xfe, 0xff, 0xff, 0x3f,\n" |
5078 | "0xfe, 0xff, 0xff, 0x3f, 0xfe, 0xff, 0xff, 0x3f, 0xfc, 0xff, 0xff, 0x1f,\n" |
5079 | "0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};\"\n" |
5080 | "image create bitmap ::tk::dialog::w3 -foreground black \\\n" |
5081 | "-data \"#define w3_width 32\\n#define w3_height 32\n" |
5082 | "static unsigned char w3_bits[] = {\n" |
5083 | "0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,\n" |
5084 | "0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,\n" |
5085 | "0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,\n" |
5086 | "0x00, 0xc0, 0x03, 0x00, 0x00, 0xe0, 0x07, 0x00, 0x00, 0xe0, 0x07, 0x00,\n" |
5087 | "0x00, 0xe0, 0x07, 0x00, 0x00, 0xe0, 0x07, 0x00, 0x00, 0xe0, 0x07, 0x00,\n" |
5088 | "0x00, 0xc0, 0x03, 0x00, 0x00, 0xc0, 0x03, 0x00, 0x00, 0xc0, 0x03, 0x00,\n" |
5089 | "0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00,\n" |
5090 | "0x00, 0x00, 0x00, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0xc0, 0x03, 0x00,\n" |
5091 | "0x00, 0xc0, 0x03, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00,\n" |
5092 | "0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,\n" |
5093 | "0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};\"\n" |
5094 | "proc tkMessageBox {args} {\n" |
5095 | "global tkPriv tcl_platform tk_strictMotif\n" |
5096 | "set w tkPrivMsgBox\n" |
5097 | "upvar #0 $w data\n" |
5098 | "set specs {\n" |
5099 | "{-default \"\" \"\" \"\"}\n" |
5100 | "{-icon \"\" \"\" \"info\"}\n" |
5101 | "{-message \"\" \"\" \"\"}\n" |
5102 | "{-parent \"\" \"\" .}\n" |
5103 | "{-title \"\" \"\" \" \"}\n" |
5104 | "{-type \"\" \"\" \"ok\"}\n" |
5105 | "}\n" |
5106 | "tclParseConfigSpec $w $specs \"\" $args\n" |
5107 | "if {[lsearch -exact {info warning error question} $data(-icon)] == -1} {\n" |
5108 | "error \"bad -icon value \\\"$data(-icon)\\\": must be error, info, question, or warning\"\n" |
5109 | "}\n" |
5110 | "if {[string equal $tcl_platform(platform) \"macintosh\"]} {\n" |
5111 | "switch -- $data(-icon) {\n" |
5112 | "\"error\" {set data(-icon) \"stop\"}\n" |
5113 | "\"warning\" {set data(-icon) \"caution\"}\n" |
5114 | "\"info\" {set data(-icon) \"note\"}\n" |
5115 | "}\n" |
5116 | "}\n" |
5117 | "if {![winfo exists $data(-parent)]} {\n" |
5118 | "error \"bad window path name \\\"$data(-parent)\\\"\"\n" |
5119 | "}\n" |
5120 | "switch -- $data(-type) {\n" |
5121 | "abortretryignore {\n" |
5122 | "set buttons {\n" |
5123 | "{abort -width 6 -text Abort -under 0}\n" |
5124 | "{retry -width 6 -text Retry -under 0}\n" |
5125 | "{ignore -width 6 -text Ignore -under 0}\n" |
5126 | "}\n" |
5127 | "}\n" |
5128 | "ok {\n" |
5129 | "set buttons {\n" |
5130 | "{ok -width 6 -text OK -under 0}\n" |
5131 | "}\n" |
5132 | "if {[string equal $data(-default) \"\"]} {\n" |
5133 | "set data(-default) \"ok\"\n" |
5134 | "}\n" |
5135 | "}\n" |
5136 | "okcancel {\n" |
5137 | "set buttons {\n" |
5138 | "{ok -width 6 -text OK -under 0}\n" |
5139 | "{cancel -width 6 -text Cancel -under 0}\n" |
5140 | "}\n" |
5141 | "}\n" |
5142 | "retrycancel {\n" |
5143 | "set buttons {\n" |
5144 | "{retry -width 6 -text Retry -under 0}\n" |
5145 | "{cancel -width 6 -text Cancel -under 0}\n" |
5146 | "}\n" |
5147 | "}\n" |
5148 | "yesno {\n" |
5149 | "set buttons {\n" |
5150 | "{yes -width 6 -text Yes -under 0}\n" |
5151 | "{no -width 6 -text No -under 0}\n" |
5152 | "}\n" |
5153 | "}\n" |
5154 | "yesnocancel {\n" |
5155 | "set buttons {\n" |
5156 | "{yes -width 6 -text Yes -under 0}\n" |
5157 | "{no -width 6 -text No -under 0}\n" |
5158 | "{cancel -width 6 -text Cancel -under 0}\n" |
5159 | "}\n" |
5160 | "}\n" |
5161 | "default {\n" |
5162 | "error \"bad -type value \\\"$data(-type)\\\": must be abortretryignore, ok, okcancel, retrycancel, yesno, or yesnocancel\"\n" |
5163 | "}\n" |
5164 | "}\n" |
5165 | "if {[string compare $data(-default) \"\"]} {\n" |
5166 | "set valid 0\n" |
5167 | "foreach btn $buttons {\n" |
5168 | "if {[string equal [lindex $btn 0] $data(-default)]} {\n" |
5169 | "set valid 1\n" |
5170 | "break\n" |
5171 | "}\n" |
5172 | "}\n" |
5173 | "if {!$valid} {\n" |
5174 | "error \"invalid default button \\\"$data(-default)\\\"\"\n" |
5175 | "}\n" |
5176 | "}\n" |
5177 | "if {[string compare $data(-parent) .]} {\n" |
5178 | "set w $data(-parent).__tk__messagebox\n" |
5179 | "} else {\n" |
5180 | "set w .__tk__messagebox\n" |
5181 | "}\n" |
5182 | "catch {destroy $w}\n" |
5183 | "toplevel $w -class Dialog\n" |
5184 | "wm title $w $data(-title)\n" |
5185 | "wm iconname $w Dialog\n" |
5186 | "wm protocol $w WM_DELETE_WINDOW { }\n" |
5187 | "if { [winfo viewable [winfo toplevel $data(-parent)]] } {\n" |
5188 | "wm transient $w $data(-parent)\n" |
5189 | "} \n" |
5190 | "if {[string equal $tcl_platform(platform) \"macintosh\"]} {\n" |
5191 | "unsupported1 style $w dBoxProc\n" |
5192 | "}\n" |
5193 | "frame $w.bot\n" |
5194 | "pack $w.bot -side bottom -fill both\n" |
5195 | "frame $w.top\n" |
5196 | "pack $w.top -side top -fill both -expand 1\n" |
5197 | "if {[string compare $tcl_platform(platform) \"macintosh\"]} {\n" |
5198 | "$w.bot configure -relief raised -bd 1\n" |
5199 | "$w.top configure -relief raised -bd 1\n" |
5200 | "}\n" |
5201 | "option add *Dialog.msg.wrapLength 3i widgetDefault\n" |
5202 | "if {[string equal $tcl_platform(platform) \"macintosh\"]} {\n" |
5203 | "option add *Dialog.msg.font system widgetDefault\n" |
5204 | "} else {\n" |
5205 | "option add *Dialog.msg.font {Times 18} widgetDefault\n" |
5206 | "}\n" |
5207 | "label $w.msg -anchor nw -justify left -text $data(-message)\n" |
5208 | "if {[string compare $data(-icon) \"\"]} {\n" |
5209 | "if {[string equal $tcl_platform(platform) \"macintosh\"] \\\n" |
5210 | "\011\011|| ([winfo depth $w] < 4) || $tk_strictMotif} {\n" |
5211 | "label $w.bitmap -bitmap $data(-icon)\n" |
5212 | "} else {\n" |
5213 | "canvas $w.bitmap -width 32 -height 32 -highlightthickness 0\n" |
5214 | "switch $data(-icon) {\n" |
5215 | "error {\n" |
5216 | "$w.bitmap create oval 0 0 31 31 -fill red -outline black\n" |
5217 | "$w.bitmap create line 9 9 23 23 -fill white -width 4\n" |
5218 | "$w.bitmap create line 9 23 23 9 -fill white -width 4\n" |
5219 | "}\n" |
5220 | "info {\n" |
5221 | "$w.bitmap create image 0 0 -anchor nw \\\n" |
5222 | "\011\011\011 -image ::tk::dialog::b1\n" |
5223 | "$w.bitmap create image 0 0 -anchor nw \\\n" |
5224 | "\011\011\011 -image ::tk::dialog::b2\n" |
5225 | "$w.bitmap create image 0 0 -anchor nw \\\n" |
5226 | "\011\011\011 -image ::tk::dialog::i\n" |
5227 | "}\n" |
5228 | "question {\n" |
5229 | "$w.bitmap create image 0 0 -anchor nw \\\n" |
5230 | "\011\011\011 -image ::tk::dialog::b1\n" |
5231 | "$w.bitmap create image 0 0 -anchor nw \\\n" |
5232 | "\011\011\011 -image ::tk::dialog::b2\n" |
5233 | "$w.bitmap create image 0 0 -anchor nw \\\n" |
5234 | "\011\011\011 -image ::tk::dialog::q\n" |
5235 | "}\n" |
5236 | "default {\n" |
5237 | "$w.bitmap create image 0 0 -anchor nw \\\n" |
5238 | "\011\011\011 -image ::tk::dialog::w1\n" |
5239 | "$w.bitmap create image 0 0 -anchor nw \\\n" |
5240 | "\011\011\011 -image ::tk::dialog::w2\n" |
5241 | "$w.bitmap create image 0 0 -anchor nw \\\n" |
5242 | "\011\011\011 -image ::tk::dialog::w3\n" |
5243 | "}\n" |
5244 | "}\n" |
5245 | "}\n" |
5246 | "}\n" |
5247 | "grid $w.bitmap $w.msg -in $w.top -sticky news -padx 2m -pady 2m\n" |
5248 | "grid columnconfigure $w.top 1 -weight 1\n" |
5249 | "grid rowconfigure $w.top 0 -weight 1\n" |
5250 | "set i 0\n" |
5251 | "foreach but $buttons {\n" |
5252 | "set name [lindex $but 0]\n" |
5253 | "set opts [lrange $but 1 end]\n" |
5254 | "if {![llength $opts]} {\n" |
5255 | "set capName [string toupper $name 0]\n" |
5256 | "set opts [list -text $capName]\n" |
5257 | "}\n" |
5258 | "eval button [list $w.$name] $opts [list -command [list set tkPriv(button) $name]]\n" |
5259 | "if {[string equal $name $data(-default)]} {\n" |
5260 | "$w.$name configure -default active\n" |
5261 | "}\n" |
5262 | "pack $w.$name -in $w.bot -side left -expand 1 -padx 3m -pady 2m\n" |
5263 | "set underIdx [$w.$name cget -under]\n" |
5264 | "if {$underIdx >= 0} {\n" |
5265 | "set key [string index [$w.$name cget -text] $underIdx]\n" |
5266 | "bind $w <Alt-[string tolower $key]> [list $w.$name invoke]\n" |
5267 | "bind $w <Alt-[string toupper $key]> [list $w.$name invoke]\n" |
5268 | "}\n" |
5269 | "incr i\n" |
5270 | "}\n" |
5271 | "if {[string compare {} $data(-default)]} {\n" |
5272 | "bind $w <FocusIn> {\n" |
5273 | "if {[string equal Button [winfo class %W]]} {\n" |
5274 | "%W configure -default active\n" |
5275 | "}\n" |
5276 | "}\n" |
5277 | "bind $w <FocusOut> {\n" |
5278 | "if {[string equal Button [winfo class %W]]} {\n" |
5279 | "%W configure -default normal\n" |
5280 | "}\n" |
5281 | "}\n" |
5282 | "}\n" |
5283 | "bind $w <Return> {\n" |
5284 | "if {[string equal Button [winfo class %W]]} {\n" |
5285 | "tkButtonInvoke %W\n" |
5286 | "}\n" |
5287 | "}\n" |
5288 | "::tk::PlaceWindow $w widget $data(-parent)\n" |
5289 | "if {[string compare $data(-default) \"\"]} {\n" |
5290 | "set focus $w.$data(-default)\n" |
5291 | "} else {\n" |
5292 | "set focus $w\n" |
5293 | "}\n" |
5294 | "::tk::SetFocusGrab $w $focus\n" |
5295 | "tkwait variable tkPriv(button)\n" |
5296 | "::tk::RestoreFocusGrab $w $focus\n" |
5297 | "return $tkPriv(button)\n" |
5298 | "}\n" |
5299 | ; |
5300 | static char Et_zFile19[] = |
5301 | "proc tk_menuBar args {}\n" |
5302 | "proc tk_bindForTraversal args {}\n" |
5303 | ; |
5304 | static char Et_zFile20[] = |
5305 | "proc tk_optionMenu {w varName firstValue args} {\n" |
5306 | "upvar #0 $varName var\n" |
5307 | "if {![info exists var]} {\n" |
5308 | "set var $firstValue\n" |
5309 | "}\n" |
5310 | "menubutton $w -textvariable $varName -indicatoron 1 -menu $w.menu \\\n" |
5311 | "\011 -relief raised -bd 2 -highlightthickness 2 -anchor c \\\n" |
5312 | "\011 -direction flush\n" |
5313 | "menu $w.menu -tearoff 0\n" |
5314 | "$w.menu add radiobutton -label $firstValue -variable $varName\n" |
5315 | "foreach i $args {\n" |
5316 | "$w.menu add radiobutton -label $i -variable $varName\n" |
5317 | "}\n" |
5318 | "return $w.menu\n" |
5319 | "}\n" |
5320 | ; |
5321 | static char Et_zFile21[] = |
5322 | "proc tk_setPalette {args} {\n" |
5323 | "if {[winfo depth .] == 1} {\n" |
5324 | "return\n" |
5325 | "}\n" |
5326 | "global tkPalette\n" |
5327 | "if {[llength $args] == 1} {\n" |
5328 | "set new(background) [lindex $args 0]\n" |
5329 | "} else {\n" |
5330 | "array set new $args\n" |
5331 | "}\n" |
5332 | "if {![info exists new(background)]} {\n" |
5333 | "error \"must specify a background color\"\n" |
5334 | "}\n" |
5335 | "if {![info exists new(foreground)]} {\n" |
5336 | "set new(foreground) black\n" |
5337 | "}\n" |
5338 | "set bg [winfo rgb . $new(background)]\n" |
5339 | "set fg [winfo rgb . $new(foreground)]\n" |
5340 | "set darkerBg [format #%02x%02x%02x [expr {(9*[lindex $bg 0])/2560}] \\\n" |
5341 | "\011 [expr {(9*[lindex $bg 1])/2560}] [expr {(9*[lindex $bg 2])/2560}]]\n" |
5342 | "foreach i {activeForeground insertBackground selectForeground \\\n" |
5343 | "\011 highlightColor} {\n" |
5344 | "if {![info exists new($i)]} {\n" |
5345 | "set new($i) $new(foreground)\n" |
5346 | "}\n" |
5347 | "}\n" |
5348 | "if {![info exists new(disabledForeground)]} {\n" |
5349 | "set new(disabledForeground) [format #%02x%02x%02x \\\n" |
5350 | "\011\011[expr {(3*[lindex $bg 0] + [lindex $fg 0])/1024}] \\\n" |
5351 | "\011\011[expr {(3*[lindex $bg 1] + [lindex $fg 1])/1024}] \\\n" |
5352 | "\011\011[expr {(3*[lindex $bg 2] + [lindex $fg 2])/1024}]]\n" |
5353 | "}\n" |
5354 | "if {![info exists new(highlightBackground)]} {\n" |
5355 | "set new(highlightBackground) $new(background)\n" |
5356 | "}\n" |
5357 | "if {![info exists new(activeBackground)]} {\n" |
5358 | "foreach i {0 1 2} {\n" |
5359 | "set light($i) [expr {[lindex $bg $i]/256}]\n" |
5360 | "set inc1 [expr {($light($i)*15)/100}]\n" |
5361 | "set inc2 [expr {(255-$light($i))/3}]\n" |
5362 | "if {$inc1 > $inc2} {\n" |
5363 | "incr light($i) $inc1\n" |
5364 | "} else {\n" |
5365 | "incr light($i) $inc2\n" |
5366 | "}\n" |
5367 | "if {$light($i) > 255} {\n" |
5368 | "set light($i) 255\n" |
5369 | "}\n" |
5370 | "}\n" |
5371 | "set new(activeBackground) [format #%02x%02x%02x $light(0) \\\n" |
5372 | "\011\011$light(1) $light(2)]\n" |
5373 | "}\n" |
5374 | "if {![info exists new(selectBackground)]} {\n" |
5375 | "set new(selectBackground) $darkerBg\n" |
5376 | "}\n" |
5377 | "if {![info exists new(troughColor)]} {\n" |
5378 | "set new(troughColor) $darkerBg\n" |
5379 | "}\n" |
5380 | "if {![info exists new(selectColor)]} {\n" |
5381 | "set new(selectColor) #b03060\n" |
5382 | "}\n" |
5383 | "toplevel .___tk_set_palette\n" |
5384 | "wm withdraw .___tk_set_palette\n" |
5385 | "foreach q {button canvas checkbutton entry frame label listbox \\\n" |
5386 | "\011 menubutton menu message radiobutton scale scrollbar text} {\n" |
5387 | "$q .___tk_set_palette.$q\n" |
5388 | "}\n" |
5389 | "eval [tkRecolorTree . new]\n" |
5390 | "catch {destroy .___tk_set_palette}\n" |
5391 | "foreach option [array names new] {\n" |
5392 | "option add *$option $new($option) widgetDefault\n" |
5393 | "}\n" |
5394 | "array set tkPalette [array get new]\n" |
5395 | "}\n" |
5396 | "proc tkRecolorTree {w colors} {\n" |
5397 | "global tkPalette\n" |
5398 | "upvar $colors c\n" |
5399 | "set result {}\n" |
5400 | "foreach dbOption [array names c] {\n" |
5401 | "set option -[string tolower $dbOption]\n" |
5402 | "if {![catch {$w config $option} value]} {\n" |
5403 | "set defaultcolor [option get $w $dbOption widgetDefault]\n" |
5404 | "if {[string match {} $defaultcolor]} {\n" |
5405 | "set defaultcolor [winfo rgb . [lindex $value 3]]\n" |
5406 | "} else {\n" |
5407 | "set defaultcolor [winfo rgb . $defaultcolor]\n" |
5408 | "}\n" |
5409 | "set chosencolor [winfo rgb . [lindex $value 4]]\n" |
5410 | "if {[string match $defaultcolor $chosencolor]} {\n" |
5411 | "append result \";\\noption add [list \\\n" |
5412 | "\011\011 *[winfo class $w].$dbOption $c($dbOption) 60]\"\n" |
5413 | "$w configure $option $c($dbOption)\n" |
5414 | "}\n" |
5415 | "}\n" |
5416 | "}\n" |
5417 | "foreach child [winfo children $w] {\n" |
5418 | "append result \";\\n[tkRecolorTree $child c]\"\n" |
5419 | "}\n" |
5420 | "return $result\n" |
5421 | "}\n" |
5422 | "proc tkDarken {color percent} {\n" |
5423 | "foreach {red green blue} [winfo rgb . $color] {\n" |
5424 | "set red [expr {($red/256)*$percent/100}]\n" |
5425 | "set green [expr {($green/256)*$percent/100}]\n" |
5426 | "set blue [expr {($blue/256)*$percent/100}]\n" |
5427 | "break\n" |
5428 | "}\n" |
5429 | "if {$red > 255} {\n" |
5430 | "set red 255\n" |
5431 | "}\n" |
5432 | "if {$green > 255} {\n" |
5433 | "set green 255\n" |
5434 | "}\n" |
5435 | "if {$blue > 255} {\n" |
5436 | "set blue 255\n" |
5437 | "}\n" |
5438 | "return [format \"#%02x%02x%02x\" $red $green $blue]\n" |
5439 | "}\n" |
5440 | "proc tk_bisque {} {\n" |
5441 | "tk_setPalette activeBackground #e6ceb1 activeForeground black \\\n" |
5442 | "\011 background #ffe4c4 disabledForeground #b0b0b0 foreground black \\\n" |
5443 | "\011 highlightBackground #ffe4c4 highlightColor black \\\n" |
5444 | "\011 insertBackground black selectColor #b03060 \\\n" |
5445 | "\011 selectBackground #e6ceb1 selectForeground black \\\n" |
5446 | "\011 troughColor #cdb79e\n" |
5447 | "}\n" |
5448 | ; |
5449 | static char Et_zFile22[] = |
5450 | "package require opt 0.4.1;\n" |
5451 | "namespace eval ::safe {\n" |
5452 | "variable tkSafeId 0;\n" |
5453 | "proc ::safe::tkInterpInit {slave argv} {\n" |
5454 | "global env tk_library\n" |
5455 | "allowTk $slave $argv\n" |
5456 | "::interp eval $slave [list set tk_library [::safe::interpAddToAccessPath $slave $tk_library]]\n" |
5457 | "return $slave\n" |
5458 | "}\n" |
5459 | "proc ::safe::loadTk {} {}\n" |
5460 | "::tcl::OptProc loadTk {\n" |
5461 | "{slave -interp \"name of the slave interpreter\"}\n" |
5462 | "{-use -windowId {} \"window Id to use (new toplevel otherwise)\"}\n" |
5463 | "{-display -displayName {} \"display name to use (current one otherwise)\"}\n" |
5464 | "} {\n" |
5465 | "set displayGiven [::tcl::OptProcArgGiven \"-display\"]\n" |
5466 | "if {!$displayGiven} {\n" |
5467 | "if {[catch {set display [winfo screen .]}]} {\n" |
5468 | "if {[info exists ::env(DISPLAY)]} {\n" |
5469 | "set display $::env(DISPLAY)\n" |
5470 | "} else {\n" |
5471 | "Log $slave \"no winfo screen . nor env(DISPLAY)\" WARNING\n" |
5472 | "set display \":0.0\"\n" |
5473 | "}\n" |
5474 | "}\n" |
5475 | "}\n" |
5476 | "if {![::tcl::OptProcArgGiven \"-use\"]} {\n" |
5477 | "::tcl::Lassign [tkTopLevel $slave $display] w use\n" |
5478 | "Set [DeleteHookName $slave] [list tkDelete {} $w]\n" |
5479 | "} else {\n" |
5480 | "Set [DeleteHookName $slave] [list disallowTk]\n" |
5481 | "if {[string match \".*\" $use]} {\n" |
5482 | "set windowName $use\n" |
5483 | "set use [winfo id $windowName]\n" |
5484 | "set nDisplay [winfo screen $windowName]\n" |
5485 | "} else {\n" |
5486 | "if {![catch {winfo pathname $use} name]} {\n" |
5487 | "set nDisplay [winfo screen $name]\n" |
5488 | "} else {\n" |
5489 | "set nDisplay $display\n" |
5490 | "}\n" |
5491 | "}\n" |
5492 | "if {[string compare $nDisplay $display]} {\n" |
5493 | "if {$displayGiven} {\n" |
5494 | "error \"conflicting -display $display and -use\\\n" |
5495 | "\011\011\011$use -> $nDisplay\"\n" |
5496 | "} else {\n" |
5497 | "set display $nDisplay\n" |
5498 | "}\n" |
5499 | "}\n" |
5500 | "}\n" |
5501 | "tkInterpInit $slave [list \"-use\" $use \"-display\" $display]\n" |
5502 | "load {} Tk $slave\n" |
5503 | "return $slave\n" |
5504 | "}\n" |
5505 | "proc ::safe::TkInit {interpPath} {\n" |
5506 | "variable tkInit\n" |
5507 | "if {[info exists tkInit($interpPath)]} {\n" |
5508 | "set value $tkInit($interpPath)\n" |
5509 | "Log $interpPath \"TkInit called, returning \\\"$value\\\"\" NOTICE\n" |
5510 | "return $value\n" |
5511 | "} else {\n" |
5512 | "Log $interpPath \"TkInit called for interp with clearance:\\\n" |
5513 | "\011\011preventing Tk init\" ERROR\n" |
5514 | "error \"not allowed\"\n" |
5515 | "}\n" |
5516 | "}\n" |
5517 | "proc ::safe::allowTk {interpPath argv} {\n" |
5518 | "variable tkInit\n" |
5519 | "set tkInit($interpPath) $argv\n" |
5520 | "return\n" |
5521 | "}\n" |
5522 | "proc ::safe::disallowTk {interpPath} {\n" |
5523 | "variable tkInit\n" |
5524 | "if {[info exists tkInit($interpPath)]} {\n" |
5525 | "unset tkInit($interpPath)\n" |
5526 | "}\n" |
5527 | "return\n" |
5528 | "}\n" |
5529 | "proc ::safe::tkDelete {W window slave} {\n" |
5530 | "Log $slave \"Called tkDelete $W $window\" NOTICE\n" |
5531 | "if {[::interp exists $slave]} {\n" |
5532 | "if {[catch {::safe::interpDelete $slave} msg]} {\n" |
5533 | "Log $slave \"Deletion error : $msg\"\n" |
5534 | "}\n" |
5535 | "}\n" |
5536 | "if {[winfo exists $window]} {\n" |
5537 | "Log $slave \"Destroy toplevel $window\" NOTICE\n" |
5538 | "destroy $window\n" |
5539 | "}\n" |
5540 | "disallowTk $slave\n" |
5541 | "return\n" |
5542 | "}\n" |
5543 | "proc ::safe::tkTopLevel {slave display} {\n" |
5544 | "variable tkSafeId\n" |
5545 | "incr tkSafeId\n" |
5546 | "set w \".safe$tkSafeId\"\n" |
5547 | "if {[catch {toplevel $w -screen $display -class SafeTk} msg]} {\n" |
5548 | "return -code error \"Unable to create toplevel for\\\n" |
5549 | "\011\011safe slave \\\"$slave\\\" ($msg)\"\n" |
5550 | "}\n" |
5551 | "Log $slave \"New toplevel $w\" NOTICE\n" |
5552 | "set msg \"Untrusted Tcl applet ($slave)\"\n" |
5553 | "wm title $w $msg\n" |
5554 | "set wc $w.fc\n" |
5555 | "frame $wc -bg red -borderwidth 3 -relief ridge\n" |
5556 | "bindtags $wc [concat Safe$wc [bindtags $wc]]\n" |
5557 | "bind Safe$wc <Destroy> [list ::safe::tkDelete %W $w $slave]\n" |
5558 | "label $wc.l -text $msg -padx 2 -pady 0 -anchor w\n" |
5559 | "frame $wc.fb -bd 0\n" |
5560 | "button $wc.fb.b -text \"Delete\" \\\n" |
5561 | "\011 -bd 1 -padx 2 -pady 0 -highlightthickness 0 \\\n" |
5562 | "\011 -command [list ::safe::tkDelete $w $w $slave]\n" |
5563 | "pack $wc.fb.b -side right -fill both\n" |
5564 | "pack $wc.fb -side right -fill both -expand 1\n" |
5565 | "pack $wc.l -side left -fill both -expand 1\n" |
5566 | "pack $wc -side bottom -fill x\n" |
5567 | "frame $w.c -container 1\n" |
5568 | "pack $w.c -fill both -expand 1\n" |
5569 | "list $w [winfo id $w.c]\n" |
5570 | "}\n" |
5571 | "}\n" |
5572 | ; |
5573 | static char Et_zFile23[] = |
5574 | "bind Scale <Enter> {\n" |
5575 | "if {$tk_strictMotif} {\n" |
5576 | "set tkPriv(activeBg) [%W cget -activebackground]\n" |
5577 | "%W config -activebackground [%W cget -background]\n" |
5578 | "}\n" |
5579 | "tkScaleActivate %W %x %y\n" |
5580 | "}\n" |
5581 | "bind Scale <Motion> {\n" |
5582 | "tkScaleActivate %W %x %y\n" |
5583 | "}\n" |
5584 | "bind Scale <Leave> {\n" |
5585 | "if {$tk_strictMotif} {\n" |
5586 | "%W config -activebackground $tkPriv(activeBg)\n" |
5587 | "}\n" |
5588 | "if {[string equal [%W cget -state] \"active\"]} {\n" |
5589 | "%W configure -state normal\n" |
5590 | "}\n" |
5591 | "}\n" |
5592 | "bind Scale <1> {\n" |
5593 | "tkScaleButtonDown %W %x %y\n" |
5594 | "}\n" |
5595 | "bind Scale <B1-Motion> {\n" |
5596 | "tkScaleDrag %W %x %y\n" |
5597 | "}\n" |
5598 | "bind Scale <B1-Leave> { }\n" |
5599 | "bind Scale <B1-Enter> { }\n" |
5600 | "bind Scale <ButtonRelease-1> {\n" |
5601 | "tkCancelRepeat\n" |
5602 | "tkScaleEndDrag %W\n" |
5603 | "tkScaleActivate %W %x %y\n" |
5604 | "}\n" |
5605 | "bind Scale <2> {\n" |