/[dtapublic]/projs/trunk/shared_source/c_tk_base_7_5_w_mods/appinit.c
ViewVC logotype

Contents of /projs/trunk/shared_source/c_tk_base_7_5_w_mods/appinit.c

Parent Directory Parent Directory | Revision Log Revision Log


Revision 71 - (show annotations) (download)
Sat Nov 5 11:07:06 2016 UTC (8 years ago) by dashley
File MIME type: text/plain
File size: 343332 byte(s)
Set EOL properties appropriately to facilitate simultaneous Linux and Windows development.
1 /* $Header$ */
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"
5606 "tkScaleButton2Down %W %x %y\n"
5607 "}\n"
5608 "bind Scale <B2-Motion> {\n"
5609 "tkScaleDrag %W %x %y\n"
5610 "}\n"
5611 "bind Scale <B2-Leave> { }\n"
5612 "bind Scale <B2-Enter> { }\n"
5613 "bind Scale <ButtonRelease-2> {\n"
5614 "tkCancelRepeat\n"
5615 "tkScaleEndDrag %W\n"
5616 "tkScaleActivate %W %x %y\n"
5617 "}\n"
5618 "bind Scale <Control-1> {\n"
5619 "tkScaleControlPress %W %x %y\n"
5620 "}\n"
5621 "bind Scale <Up> {\n"
5622 "tkScaleIncrement %W up little noRepeat\n"
5623 "}\n"
5624 "bind Scale <Down> {\n"
5625 "tkScaleIncrement %W down little noRepeat\n"
5626 "}\n"
5627 "bind Scale <Left> {\n"
5628 "tkScaleIncrement %W up little noRepeat\n"
5629 "}\n"
5630 "bind Scale <Right> {\n"
5631 "tkScaleIncrement %W down little noRepeat\n"
5632 "}\n"
5633 "bind Scale <Control-Up> {\n"
5634 "tkScaleIncrement %W up big noRepeat\n"
5635 "}\n"
5636 "bind Scale <Control-Down> {\n"
5637 "tkScaleIncrement %W down big noRepeat\n"