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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 42 - (show annotations) (download)
Fri Oct 14 01:50:00 2016 UTC (7 years, 5 months ago) by dashley
File MIME type: text/plain
File size: 355233 byte(s)
Move shared source code to commonize.
1 /* $Header: /cvsroot/esrg/sfesrg/esrgpcpj/shared/tk_base/appinit.c,v 1.6 2002/04/23 06:26:42 dtashley Exp $ */
2
3 #define MODULE_APPINIT
4
5 #include <tcl.h>
6
7 #include "appinit.h"
8 #include "build_config.h"
9 #include "extninit.h"
10 #include "msgstrs.h"
11
12
13 #define INTERFACE 1
14 #if INTERFACE
15 #define ET_TCLARGS ClientData clientData,Tcl_Interp*interp,int argc,char**argv
16 #define ET_OBJARGS ClientData clientData,Tcl_Interp*interp,int objc,Tcl_Obj*CONST objv[]
17 #endif
18 #define ET_ENABLE_OBJ 0
19 #define ET_ENABLE_TK 1
20 #define ET_AUTO_FORK 0
21 #define ET_STANDALONE 0
22 #define ET_N_BUILTIN_SCRIPT 31
23 #define ET_VERSION "3.10"
24 #define ET_HAVE_APPINIT 0
25 #define ET_HAVE_PREINIT 0
26 #define ET_HAVE_MAIN 1
27 #define ET_HAVE_CUSTOM_MAINLOOP 0
28 #define ET_EXTENSION 0
29 #define ET_SHROUD_KEY 0
30 #define ET_READ_STDIN 0
31 #define ET_CONSOLE 1
32 static struct {
33 char *zName;
34 int (*xProc)(ET_TCLARGS);
35 } Et_CmdSet[] = {
36 {0, 0}};
37 static char Et_zFile0[] =
38 "proc auto_reset {} {\n"
39 "global auto_execs auto_index auto_oldpath\n"
40 "foreach p [info procs] {\n"
41 "if {[info exists auto_index($p)] && ![string match auto_* $p]\n"
42 "&& ([lsearch -exact {unknown pkg_mkIndex tclPkgSetup\n"
43 "tcl_findLibrary pkg_compareExtension\n"
44 "tclMacPkgSearch tclPkgUnknown} $p] < 0)} {\n"
45 "rename $p {}\n"
46 "}\n"
47 "}\n"
48 "catch {unset auto_execs}\n"
49 "catch {unset auto_index}\n"
50 "catch {unset auto_oldpath}\n"
51 "}\n"
52 "proc tcl_findLibrary {basename version patch initScript enVarName varName} {\n"
53 "upvar #0 $varName the_library\n"
54 "global env errorInfo\n"
55 "set dirs {}\n"
56 "set errors {}\n"
57 "if {[info exist the_library] && [string compare $the_library {}]} {\n"
58 "lappend dirs $the_library\n"
59 "} else {\n"
60 "if {[info exists env($enVarName)]} {\n"
61 "lappend dirs $env($enVarName)\n"
62 "}\n"
63 "lappend dirs [file join [file dirname [info library]] \\\n"
64 "\011\011$basename$version]\n"
65 "set parentDir [file dirname [file dirname [info nameofexecutable]]]\n"
66 "set grandParentDir [file dirname $parentDir]\n"
67 "lappend dirs [file join $parentDir lib $basename$version]\n"
68 "lappend dirs [file join $grandParentDir lib $basename$version]\n"
69 "lappend dirs [file join $parentDir library]\n"
70 "lappend dirs [file join $grandParentDir library]\n"
71 "if {![regexp {.*[ab][0-9]*} $patch ver]} {\n"
72 "set ver $version\n"
73 "}\n"
74 "lappend dirs [file join $grandParentDir $basename$ver library]\n"
75 "lappend dirs [file join [file dirname $grandParentDir] $basename$ver library]\n"
76 "}\n"
77 "foreach i $dirs {\n"
78 "set the_library $i\n"
79 "set file [file join $i $initScript]\n"
80 "if {[interp issafe] || [file exists $file]} {\n"
81 "if {![catch {uplevel #0 [list source $file]} msg]} {\n"
82 "return\n"
83 "} else {\n"
84 "append errors \"$file: $msg\\n$errorInfo\\n\"\n"
85 "}\n"
86 "}\n"
87 "}\n"
88 "set msg \"Can't find a usable $initScript in the following directories: \\n\"\n"
89 "append msg \" $dirs\\n\\n\"\n"
90 "append msg \"$errors\\n\\n\"\n"
91 "append msg \"This probably means that $basename wasn't installed properly.\\n\"\n"
92 "error $msg\n"
93 "}\n"
94 "if {[interp issafe]} {\n"
95 "return\011;# Stop sourcing the file here\n"
96 "}\n"
97 "proc auto_mkindex {dir args} {\n"
98 "global errorCode errorInfo\n"
99 "if {[interp issafe]} {\n"
100 "error \"can't generate index within safe interpreter\"\n"
101 "}\n"
102 "set oldDir [pwd]\n"
103 "cd $dir\n"
104 "set dir [pwd]\n"
105 "append index \"# Tcl autoload index file, version 2.0\\n\"\n"
106 "append index \"# This file is generated by the \\\"auto_mkindex\\\" command\\n\"\n"
107 "append index \"# and sourced to set up indexing information for one or\\n\"\n"
108 "append index \"# more commands. Typically each line is a command that\\n\"\n"
109 "append index \"# sets an element in the auto_index array, where the\\n\"\n"
110 "append index \"# element name is the name of a command and the value is\\n\"\n"
111 "append index \"# a script that loads the command.\\n\\n\"\n"
112 "if {$args == \"\"} {\n"
113 "set args *.tcl\n"
114 "}\n"
115 "auto_mkindex_parser::init\n"
116 "foreach file [eval glob $args] {\n"
117 "if {[catch {auto_mkindex_parser::mkindex $file} msg] == 0} {\n"
118 "append index $msg\n"
119 "} else {\n"
120 "set code $errorCode\n"
121 "set info $errorInfo\n"
122 "cd $oldDir\n"
123 "error $msg $info $code\n"
124 "}\n"
125 "}\n"
126 "auto_mkindex_parser::cleanup\n"
127 "set fid [open \"tclIndex\" w]\n"
128 "puts -nonewline $fid $index\n"
129 "close $fid\n"
130 "cd $oldDir\n"
131 "}\n"
132 "proc auto_mkindex_old {dir args} {\n"
133 "global errorCode errorInfo\n"
134 "set oldDir [pwd]\n"
135 "cd $dir\n"
136 "set dir [pwd]\n"
137 "append index \"# Tcl autoload index file, version 2.0\\n\"\n"
138 "append index \"# This file is generated by the \\\"auto_mkindex\\\" command\\n\"\n"
139 "append index \"# and sourced to set up indexing information for one or\\n\"\n"
140 "append index \"# more commands. Typically each line is a command that\\n\"\n"
141 "append index \"# sets an element in the auto_index array, where the\\n\"\n"
142 "append index \"# element name is the name of a command and the value is\\n\"\n"
143 "append index \"# a script that loads the command.\\n\\n\"\n"
144 "if {[string equal $args \"\"]} {\n"
145 "set args *.tcl\n"
146 "}\n"
147 "foreach file [eval glob $args] {\n"
148 "set f \"\"\n"
149 "set error [catch {\n"
150 "set f [open $file]\n"
151 "while {[gets $f line] >= 0} {\n"
152 "if {[regexp {^proc[ \011]+([^ \011]*)} $line match procName]} {\n"
153 "set procName [lindex [auto_qualify $procName \"::\"] 0]\n"
154 "append index \"set [list auto_index($procName)]\"\n"
155 "append index \" \\[list source \\[file join \\$dir [list $file]\\]\\]\\n\"\n"
156 "}\n"
157 "}\n"
158 "close $f\n"
159 "} msg]\n"
160 "if {$error} {\n"
161 "set code $errorCode\n"
162 "set info $errorInfo\n"
163 "catch {close $f}\n"
164 "cd $oldDir\n"
165 "error $msg $info $code\n"
166 "}\n"
167 "}\n"
168 "set f \"\"\n"
169 "set error [catch {\n"
170 "set f [open tclIndex w]\n"
171 "puts -nonewline $f $index\n"
172 "close $f\n"
173 "cd $oldDir\n"
174 "} msg]\n"
175 "if {$error} {\n"
176 "set code $errorCode\n"
177 "set info $errorInfo\n"
178 "catch {close $f}\n"
179 "cd $oldDir\n"
180 "error $msg $info $code\n"
181 "}\n"
182 "}\n"
183 "namespace eval auto_mkindex_parser {\n"
184 "variable parser \"\" ;# parser used to build index\n"
185 "variable index \"\" ;# maintains index as it is built\n"
186 "variable scriptFile \"\" ;# name of file being processed\n"
187 "variable contextStack \"\" ;# stack of namespace scopes\n"
188 "variable imports \"\" ;# keeps track of all imported cmds\n"
189 "variable initCommands \"\" ;# list of commands that create aliases\n"
190 "proc init {} {\n"
191 "variable parser\n"
192 "variable initCommands\n"
193 "if {![interp issafe]} {\n"
194 "set parser [interp create -safe]\n"
195 "$parser hide info\n"
196 "$parser hide rename\n"
197 "$parser hide proc\n"
198 "$parser hide namespace\n"
199 "$parser hide eval\n"
200 "$parser hide puts\n"
201 "$parser invokehidden namespace delete ::\n"
202 "$parser invokehidden proc unknown {args} {}\n"
203 "$parser expose namespace\n"
204 "$parser invokehidden rename namespace _%@namespace\n"
205 "$parser expose eval\n"
206 "$parser invokehidden rename eval _%@eval\n"
207 "foreach cmd $initCommands {\n"
208 "eval $cmd\n"
209 "}\n"
210 "}\n"
211 "}\n"
212 "proc cleanup {} {\n"
213 "variable parser\n"
214 "interp delete $parser\n"
215 "unset parser\n"
216 "}\n"
217 "}\n"
218 "proc auto_mkindex_parser::mkindex {file} {\n"
219 "variable parser\n"
220 "variable index\n"
221 "variable scriptFile\n"
222 "variable contextStack\n"
223 "variable imports\n"
224 "set scriptFile $file\n"
225 "set fid [open $file]\n"
226 "set contents [read $fid]\n"
227 "close $fid\n"
228 "regsub -all {\\$} $contents \"\\0\" contents\n"
229 "set index \"\"\n"
230 "set contextStack \"\"\n"
231 "set imports \"\"\n"
232 "$parser eval $contents\n"
233 "foreach name $imports {\n"
234 "catch {$parser eval [list _%@namespace forget $name]}\n"
235 "}\n"
236 "return $index\n"
237 "}\n"
238 "proc auto_mkindex_parser::hook {cmd} {\n"
239 "variable initCommands\n"
240 "lappend initCommands $cmd\n"
241 "}\n"
242 "proc auto_mkindex_parser::slavehook {cmd} {\n"
243 "variable initCommands\n"
244 "lappend initCommands \"\\$parser eval [list $cmd]\"\n"
245 "}\n"
246 "proc auto_mkindex_parser::command {name arglist body} {\n"
247 "hook [list auto_mkindex_parser::commandInit $name $arglist $body]\n"
248 "}\n"
249 "proc auto_mkindex_parser::commandInit {name arglist body} {\n"
250 "variable parser\n"
251 "set ns [namespace qualifiers $name]\n"
252 "set tail [namespace tail $name]\n"
253 "if {[string equal $ns \"\"]} {\n"
254 "set fakeName \"[namespace current]::_%@fake_$tail\"\n"
255 "} else {\n"
256 "set fakeName \"_%@fake_$name\"\n"
257 "regsub -all {::} $fakeName \"_\" fakeName\n"
258 "set fakeName \"[namespace current]::$fakeName\"\n"
259 "}\n"
260 "proc $fakeName $arglist $body\n"
261 "if {[regexp {::} $name]} {\n"
262 "set exportCmd [list _%@namespace export [namespace tail $name]]\n"
263 "$parser eval [list _%@namespace eval $ns $exportCmd]\n"
264 "set alias [namespace tail $fakeName]\n"
265 "$parser invokehidden proc $name {args} \"_%@eval {$alias} \\$args\"\n"
266 "$parser alias $alias $fakeName\n"
267 "} else {\n"
268 "$parser alias $name $fakeName\n"
269 "}\n"
270 "return\n"
271 "}\n"
272 "proc auto_mkindex_parser::fullname {name} {\n"
273 "variable contextStack\n"
274 "if {![string match ::* $name]} {\n"
275 "foreach ns $contextStack {\n"
276 "set name \"${ns}::$name\"\n"
277 "if {[string match ::* $name]} {\n"
278 "break\n"
279 "}\n"
280 "}\n"
281 "}\n"
282 "if {[string equal [namespace qualifiers $name] \"\"]} {\n"
283 "set name [namespace tail $name]\n"
284 "} elseif {![string match ::* $name]} {\n"
285 "set name \"::$name\"\n"
286 "}\n"
287 "regsub -all \"\\0\" $name \"\\$\" name\n"
288 "return $name\n"
289 "}\n"
290 "auto_mkindex_parser::command proc {name args} {\n"
291 "variable index\n"
292 "variable scriptFile\n"
293 "append index [list set auto_index([fullname $name])] \\\n"
294 "\011 [format { [list source [file join $dir %s]]} \\\n"
295 "\011 [file split $scriptFile]] \"\\n\"\n"
296 "}\n"
297 "auto_mkindex_parser::hook {\n"
298 "if {![catch {package require tbcload}]} {\n"
299 "if {[llength [info commands tbcload::bcproc]] == 0} {\n"
300 "auto_load tbcload::bcproc\n"
301 "}\n"
302 "load {} tbcload $auto_mkindex_parser::parser\n"
303 "auto_mkindex_parser::commandInit tbcload::bcproc {name args} {\n"
304 "variable index\n"
305 "variable scriptFile\n"
306 "append index [list set auto_index([fullname $name])] \\\n"
307 "\011\011 [format { [list source [file join $dir %s]]} \\\n"
308 "\011\011 [file split $scriptFile]] \"\\n\"\n"
309 "}\n"
310 "}\n"
311 "}\n"
312 "auto_mkindex_parser::command namespace {op args} {\n"
313 "switch -- $op {\n"
314 "eval {\n"
315 "variable parser\n"
316 "variable contextStack\n"
317 "set name [lindex $args 0]\n"
318 "set args [lrange $args 1 end]\n"
319 "set contextStack [linsert $contextStack 0 $name]\n"
320 "$parser eval [list _%@namespace eval $name] $args\n"
321 "set contextStack [lrange $contextStack 1 end]\n"
322 "}\n"
323 "import {\n"
324 "variable parser\n"
325 "variable imports\n"
326 "foreach pattern $args {\n"
327 "if {[string compare $pattern \"-force\"]} {\n"
328 "lappend imports $pattern\n"
329 "}\n"
330 "}\n"
331 "catch {$parser eval \"_%@namespace import $args\"}\n"
332 "}\n"
333 "}\n"
334 "}\n"
335 "return\n"
336 ;
337 static char Et_zFile1[] =
338 "namespace eval tcl {\n"
339 "variable history\n"
340 "if {![info exists history]} {\n"
341 "array set history {\n"
342 "nextid\0110\n"
343 "keep\01120\n"
344 "oldest\011-20\n"
345 "}\n"
346 "}\n"
347 "}\n"
348 "proc history {args} {\n"
349 "set len [llength $args]\n"
350 "if {$len == 0} {\n"
351 "return [tcl::HistInfo]\n"
352 "}\n"
353 "set key [lindex $args 0]\n"
354 "set options \"add, change, clear, event, info, keep, nextid, or redo\"\n"
355 "switch -glob -- $key {\n"
356 "a* { # history add\n"
357 "if {$len > 3} {\n"
358 "return -code error \"wrong # args: should be \\\"history add event ?exec?\\\"\"\n"
359 "}\n"
360 "if {![string match $key* add]} {\n"
361 "return -code error \"bad option \\\"$key\\\": must be $options\"\n"
362 "}\n"
363 "if {$len == 3} {\n"
364 "set arg [lindex $args 2]\n"
365 "if {! ([string match e* $arg] && [string match $arg* exec])} {\n"
366 "return -code error \"bad argument \\\"$arg\\\": should be \\\"exec\\\"\"\n"
367 "}\n"
368 "}\n"
369 "return [tcl::HistAdd [lindex $args 1] [lindex $args 2]]\n"
370 "}\n"
371 "ch* { # history change\n"
372 "if {($len > 3) || ($len < 2)} {\n"
373 "return -code error \"wrong # args: should be \\\"history change newValue ?event?\\\"\"\n"
374 "}\n"
375 "if {![string match $key* change]} {\n"
376 "return -code error \"bad option \\\"$key\\\": must be $options\"\n"
377 "}\n"
378 "if {$len == 2} {\n"
379 "set event 0\n"
380 "} else {\n"
381 "set event [lindex $args 2]\n"
382 "}\n"
383 "return [tcl::HistChange [lindex $args 1] $event]\n"
384 "}\n"
385 "cl* { # history clear\n"
386 "if {($len > 1)} {\n"
387 "return -code error \"wrong # args: should be \\\"history clear\\\"\"\n"
388 "}\n"
389 "if {![string match $key* clear]} {\n"
390 "return -code error \"bad option \\\"$key\\\": must be $options\"\n"
391 "}\n"
392 "return [tcl::HistClear]\n"
393 "}\n"
394 "e* { # history event\n"
395 "if {$len > 2} {\n"
396 "return -code error \"wrong # args: should be \\\"history event ?event?\\\"\"\n"
397 "}\n"
398 "if {![string match $key* event]} {\n"
399 "return -code error \"bad option \\\"$key\\\": must be $options\"\n"
400 "}\n"
401 "if {$len == 1} {\n"
402 "set event -1\n"
403 "} else {\n"
404 "set event [lindex $args 1]\n"
405 "}\n"
406 "return [tcl::HistEvent $event]\n"
407 "}\n"
408 "i* { # history info\n"
409 "if {$len > 2} {\n"
410 "return -code error \"wrong # args: should be \\\"history info ?count?\\\"\"\n"
411 "}\n"
412 "if {![string match $key* info]} {\n"
413 "return -code error \"bad option \\\"$key\\\": must be $options\"\n"
414 "}\n"
415 "return [tcl::HistInfo [lindex $args 1]]\n"
416 "}\n"
417 "k* { # history keep\n"
418 "if {$len > 2} {\n"
419 "return -code error \"wrong # args: should be \\\"history keep ?count?\\\"\"\n"
420 "}\n"
421 "if {$len == 1} {\n"
422 "return [tcl::HistKeep]\n"
423 "} else {\n"
424 "set limit [lindex $args 1]\n"
425 "if {[catch {expr {~$limit}}] || ($limit < 0)} {\n"
426 "return -code error \"illegal keep count \\\"$limit\\\"\"\n"
427 "}\n"
428 "return [tcl::HistKeep $limit]\n"
429 "}\n"
430 "}\n"
431 "n* { # history nextid\n"
432 "if {$len > 1} {\n"
433 "return -code error \"wrong # args: should be \\\"history nextid\\\"\"\n"
434 "}\n"
435 "if {![string match $key* nextid]} {\n"
436 "return -code error \"bad option \\\"$key\\\": must be $options\"\n"
437 "}\n"
438 "return [expr {$tcl::history(nextid) + 1}]\n"
439 "}\n"
440 "r* { # history redo\n"
441 "if {$len > 2} {\n"
442 "return -code error \"wrong # args: should be \\\"history redo ?event?\\\"\"\n"
443 "}\n"
444 "if {![string match $key* redo]} {\n"
445 "return -code error \"bad option \\\"$key\\\": must be $options\"\n"
446 "}\n"
447 "return [tcl::HistRedo [lindex $args 1]]\n"
448 "}\n"
449 "default {\n"
450 "return -code error \"bad option \\\"$key\\\": must be $options\"\n"
451 "}\n"
452 "}\n"
453 "}\n"
454 "proc tcl::HistAdd {command {exec {}}} {\n"
455 "variable history\n"
456 "set i [incr history(nextid)]\n"
457 "set history($i) $command\n"
458 "set j [incr history(oldest)]\n"
459 "if {[info exists history($j)]} {unset history($j)}\n"
460 "if {[string match e* $exec]} {\n"
461 "return [uplevel #0 $command]\n"
462 "} else {\n"
463 "return {}\n"
464 "}\n"
465 "}\n"
466 "proc tcl::HistKeep {{limit {}}} {\n"
467 "variable history\n"
468 "if {[string length $limit] == 0} {\n"
469 "return $history(keep)\n"
470 "} else {\n"
471 "set oldold $history(oldest)\n"
472 "set history(oldest) [expr {$history(nextid) - $limit}]\n"
473 "for {} {$oldold <= $history(oldest)} {incr oldold} {\n"
474 "if {[info exists history($oldold)]} {unset history($oldold)}\n"
475 "}\n"
476 "set history(keep) $limit\n"
477 "}\n"
478 "}\n"
479 "proc tcl::HistClear {} {\n"
480 "variable history\n"
481 "set keep $history(keep)\n"
482 "unset history\n"
483 "array set history [list \\\n"
484 "\011nextid\0110\011\\\n"
485 "\011keep\011$keep\011\\\n"
486 "\011oldest\011-$keep\011\\\n"
487 " ]\n"
488 "}\n"
489 "proc tcl::HistInfo {{num {}}} {\n"
490 "variable history\n"
491 "if {$num == {}} {\n"
492 "set num [expr {$history(keep) + 1}]\n"
493 "}\n"
494 "set result {}\n"
495 "set newline \"\"\n"
496 "for {set i [expr {$history(nextid) - $num + 1}]} \\\n"
497 "\011 {$i <= $history(nextid)} {incr i} {\n"
498 "if {![info exists history($i)]} {\n"
499 "continue\n"
500 "}\n"
501 "set cmd [string trimright $history($i) \\ \\n]\n"
502 "regsub -all \\n $cmd \"\\n\\t\" cmd\n"
503 "append result $newline[format \"%6d %s\" $i $cmd]\n"
504 "set newline \\n\n"
505 "}\n"
506 "return $result\n"
507 "}\n"
508 "proc tcl::HistRedo {{event -1}} {\n"
509 "variable history\n"
510 "if {[string length $event] == 0} {\n"
511 "set event -1\n"
512 "}\n"
513 "set i [HistIndex $event]\n"
514 "if {$i == $history(nextid)} {\n"
515 "return -code error \"cannot redo the current event\"\n"
516 "}\n"
517 "set cmd $history($i)\n"
518 "HistChange $cmd 0\n"
519 "uplevel #0 $cmd\n"
520 "}\n"
521 "proc tcl::HistIndex {event} {\n"
522 "variable history\n"
523 "if {[catch {expr {~$event}}]} {\n"
524 "for {set i $history(nextid)} {[info exists history($i)]} {incr i -1} {\n"
525 "if {[string match $event* $history($i)]} {\n"
526 "return $i;\n"
527 "}\n"
528 "if {[string match $event $history($i)]} {\n"
529 "return $i;\n"
530 "}\n"
531 "}\n"
532 "return -code error \"no event matches \\\"$event\\\"\"\n"
533 "} elseif {$event <= 0} {\n"
534 "set i [expr {$history(nextid) + $event}]\n"
535 "} else {\n"
536 "set i $event\n"
537 "}\n"
538 "if {$i <= $history(oldest)} {\n"
539 "return -code error \"event \\\"$event\\\" is too far in the past\"\n"
540 "}\n"
541 "if {$i > $history(nextid)} {\n"
542 "return -code error \"event \\\"$event\\\" hasn't occured yet\"\n"
543 "}\n"
544 "return $i\n"
545 "}\n"
546 "proc tcl::HistEvent {event} {\n"
547 "variable history\n"
548 "set i [HistIndex $event]\n"
549 "if {[info exists history($i)]} {\n"
550 "return [string trimright $history($i) \\ \\n]\n"
551 "} else {\n"
552 "return \"\";\n"
553 "}\n"
554 "}\n"
555 "proc tcl::HistChange {cmd {event 0}} {\n"
556 "variable history\n"
557 "set i [HistIndex $event]\n"
558 "set history($i) $cmd\n"
559 "}\n"
560 ;
561 static char Et_zFile2[] =
562 "if {[info commands package] == \"\"} {\n"
563 "error \"version mismatch: library\\nscripts expect Tcl version 7.5b1 or later but the loaded version is\\nonly [info patchlevel]\"\n"
564 "}\n"
565 "package require -exact Tcl 8.3\n"
566 "if {![info exists auto_path]} {\n"
567 "if {[info exist env(TCLLIBPATH)]} {\n"
568 "set auto_path $env(TCLLIBPATH)\n"
569 "} else {\n"
570 "set auto_path \"\"\n"
571 "}\n"
572 "}\n"
573 "if {[string compare [info library] {}]} {\n"
574 "foreach __dir [list [info library] [file dirname [info library]]] {\n"
575 "if {[lsearch -exact $auto_path $__dir] < 0} {\n"
576 "lappend auto_path $__dir\n"
577 "}\n"
578 "}\n"
579 "}\n"
580 "set __dir [file join [file dirname [file dirname \\\n"
581 "\011[info nameofexecutable]]] lib]\n"
582 "if {[lsearch -exact $auto_path $__dir] < 0} {\n"
583 "lappend auto_path $__dir\n"
584 "}\n"
585 "if {[info exist tcl_pkgPath]} {\n"
586 "foreach __dir $tcl_pkgPath {\n"
587 "if {[lsearch -exact $auto_path $__dir] < 0} {\n"
588 "lappend auto_path $__dir\n"
589 "}\n"
590 "}\n"
591 "}\n"
592 "if {[info exists __dir]} {\n"
593 "unset __dir\n"
594 "}\n"
595 "if {(![interp issafe]) && [string equal $tcl_platform(platform) \"windows\"]} {\n"
596 "namespace eval tcl {\n"
597 "proc envTraceProc {lo n1 n2 op} {\n"
598 "set x $::env($n2)\n"
599 "set ::env($lo) $x\n"
600 "set ::env([string toupper $lo]) $x\n"
601 "}\n"
602 "}\n"
603 "foreach p [array names env] {\n"
604 "set u [string toupper $p]\n"
605 "if {[string compare $u $p]} {\n"
606 "switch -- $u {\n"
607 "COMSPEC -\n"
608 "PATH {\n"
609 "if {![info exists env($u)]} {\n"
610 "set env($u) $env($p)\n"
611 "}\n"
612 "trace variable env($p) w [list tcl::envTraceProc $p]\n"
613 "trace variable env($u) w [list tcl::envTraceProc $p]\n"
614 "}\n"
615 "}\n"
616 "}\n"
617 "}\n"
618 "if {[info exists p]} {\n"
619 "unset p\n"
620 "}\n"
621 "if {[info exists u]} {\n"
622 "unset u\n"
623 "}\n"
624 "if {![info exists env(COMSPEC)]} {\n"
625 "if {[string equal $tcl_platform(os) \"Windows NT\"]} {\n"
626 "set env(COMSPEC) cmd.exe\n"
627 "} else {\n"
628 "set env(COMSPEC) command.com\n"
629 "}\n"
630 "}\n"
631 "}\n"
632 "package unknown tclPkgUnknown\n"
633 "if {[llength [info commands exec]] == 0} {\n"
634 "set auto_noexec 1\n"
635 "}\n"
636 "set errorCode \"\"\n"
637 "set errorInfo \"\"\n"
638 "if {[llength [info commands tclLog]] == 0} {\n"
639 "proc tclLog {string} {\n"
640 "catch {puts stderr $string}\n"
641 "}\n"
642 "}\n"
643 "proc unknown args {\n"
644 "global auto_noexec auto_noload env unknown_pending tcl_interactive\n"
645 "global errorCode errorInfo\n"
646 "set cmd [lindex $args 0]\n"
647 "if {[regexp \"^namespace\\[ \\t\\n\\]+inscope\" $cmd] && [llength $cmd] == 4} {\n"
648 "set arglist [lrange $args 1 end]\n"
649 "set ret [catch {uplevel $cmd $arglist} result]\n"
650 "if {$ret == 0} {\n"
651 "return $result\n"
652 "} else {\n"
653 "return -code $ret -errorcode $errorCode $result\n"
654 "}\n"
655 "}\n"
656 "set savedErrorCode $errorCode\n"
657 "set savedErrorInfo $errorInfo\n"
658 "set name [lindex $args 0]\n"
659 "if {![info exists auto_noload]} {\n"
660 "if {[info exists unknown_pending($name)]} {\n"
661 "return -code error \"self-referential recursion in \\\"unknown\\\" for command \\\"$name\\\"\";\n"
662 "}\n"
663 "set unknown_pending($name) pending;\n"
664 "set ret [catch {auto_load $name [uplevel 1 {namespace current}]} msg]\n"
665 "unset unknown_pending($name);\n"
666 "if {$ret != 0} {\n"
667 "append errorInfo \"\\n (autoloading \\\"$name\\\")\"\n"
668 "return -code $ret -errorcode $errorCode -errorinfo $errorInfo $msg\n"
669 "}\n"
670 "if {![array size unknown_pending]} {\n"
671 "unset unknown_pending\n"
672 "}\n"
673 "if {$msg} {\n"
674 "set errorCode $savedErrorCode\n"
675 "set errorInfo $savedErrorInfo\n"
676 "set code [catch {uplevel 1 $args} msg]\n"
677 "if {$code == 1} {\n"
678 "set new [split $errorInfo \\n]\n"
679 "set new [join [lrange $new 0 [expr {[llength $new] - 6}]] \\n]\n"
680 "return -code error -errorcode $errorCode \\\n"
681 "\011\011\011-errorinfo $new $msg\n"
682 "} else {\n"
683 "return -code $code $msg\n"
684 "}\n"
685 "}\n"
686 "}\n"
687 "if {([info level] == 1) && [string equal [info script] \"\"] \\\n"
688 "\011 && [info exists tcl_interactive] && $tcl_interactive} {\n"
689 "if {![info exists auto_noexec]} {\n"
690 "set new [auto_execok $name]\n"
691 "if {[string compare {} $new]} {\n"
692 "set errorCode $savedErrorCode\n"
693 "set errorInfo $savedErrorInfo\n"
694 "set redir \"\"\n"
695 "if {[string equal [info commands console] \"\"]} {\n"
696 "set redir \">&@stdout <@stdin\"\n"
697 "}\n"
698 "return [uplevel exec $redir $new [lrange $args 1 end]]\n"
699 "}\n"
700 "}\n"
701 "set errorCode $savedErrorCode\n"
702 "set errorInfo $savedErrorInfo\n"
703 "if {[string equal $name \"!!\"]} {\n"
704 "set newcmd [history event]\n"
705 "} elseif {[regexp {^!(.+)$} $name dummy event]} {\n"
706 "set newcmd [history event $event]\n"
707 "} elseif {[regexp {^\\^([^^]*)\\^([^^]*)\\^?$} $name dummy old new]} {\n"
708 "set newcmd [history event -1]\n"
709 "catch {regsub -all -- $old $newcmd $new newcmd}\n"
710 "}\n"
711 "if {[info exists newcmd]} {\n"
712 "tclLog $newcmd\n"
713 "history change $newcmd 0\n"
714 "return [uplevel $newcmd]\n"
715 "}\n"
716 "set ret [catch {set cmds [info commands $name*]} msg]\n"
717 "if {[string equal $name \"::\"]} {\n"
718 "set name \"\"\n"
719 "}\n"
720 "if {$ret != 0} {\n"
721 "return -code $ret -errorcode $errorCode \\\n"
722 "\011\011\"error in unknown while checking if \\\"$name\\\" is a unique command abbreviation: $msg\"\n"
723 "}\n"
724 "if {[llength $cmds] == 1} {\n"
725 "return [uplevel [lreplace $args 0 0 $cmds]]\n"
726 "}\n"
727 "if {[llength $cmds]} {\n"
728 "if {[string equal $name \"\"]} {\n"
729 "return -code error \"empty command name \\\"\\\"\"\n"
730 "} else {\n"
731 "return -code error \\\n"
732 "\011\011\011\"ambiguous command name \\\"$name\\\": [lsort $cmds]\"\n"
733 "}\n"
734 "}\n"
735 "}\n"
736 "return -code error \"invalid command name \\\"$name\\\"\"\n"
737 "}\n"
738 "proc auto_load {cmd {namespace {}}} {\n"
739 "global auto_index auto_oldpath auto_path\n"
740 "if {[string length $namespace] == 0} {\n"
741 "set namespace [uplevel {namespace current}]\n"
742 "}\n"
743 "set nameList [auto_qualify $cmd $namespace]\n"
744 "lappend nameList $cmd\n"
745 "foreach name $nameList {\n"
746 "if {[info exists auto_index($name)]} {\n"
747 "uplevel #0 $auto_index($name)\n"
748 "return [expr {[info commands $name] != \"\"}]\n"
749 "}\n"
750 "}\n"
751 "if {![info exists auto_path]} {\n"
752 "return 0\n"
753 "}\n"
754 "if {![auto_load_index]} {\n"
755 "return 0\n"
756 "}\n"
757 "foreach name $nameList {\n"
758 "if {[info exists auto_index($name)]} {\n"
759 "uplevel #0 $auto_index($name)\n"
760 "if { ![string equal [namespace which -command $name] \"\"] } {\n"
761 "return 1\n"
762 "}\n"
763 "}\n"
764 "}\n"
765 "return 0\n"
766 "}\n"
767 "proc auto_load_index {} {\n"
768 "global auto_index auto_oldpath auto_path errorInfo errorCode\n"
769 "if {[info exists auto_oldpath] && \\\n"
770 "\011 [string equal $auto_oldpath $auto_path]} {\n"
771 "return 0\n"
772 "}\n"
773 "set auto_oldpath $auto_path\n"
774 "set issafe [interp issafe]\n"
775 "for {set i [expr {[llength $auto_path] - 1}]} {$i >= 0} {incr i -1} {\n"
776 "set dir [lindex $auto_path $i]\n"
777 "set f \"\"\n"
778 "if {$issafe} {\n"
779 "catch {source [file join $dir tclIndex]}\n"
780 "} elseif {[catch {set f [open [file join $dir tclIndex]]}]} {\n"
781 "continue\n"
782 "} else {\n"
783 "set error [catch {\n"
784 "set id [gets $f]\n"
785 "if {[string equal $id \\\n"
786 "\011\011\011\"# Tcl autoload index file, version 2.0\"]} {\n"
787 "eval [read $f]\n"
788 "} elseif {[string equal $id \"# Tcl autoload index file: each line identifies a Tcl\"]} {\n"
789 "while {[gets $f line] >= 0} {\n"
790 "if {[string equal [string index $line 0] \"#\"] \\\n"
791 "\011\011\011\011|| ([llength $line] != 2)} {\n"
792 "continue\n"
793 "}\n"
794 "set name [lindex $line 0]\n"
795 "set auto_index($name) \\\n"
796 "\011\011\011\011\"source [file join $dir [lindex $line 1]]\"\n"
797 "}\n"
798 "} else {\n"
799 "error \"[file join $dir tclIndex] isn't a proper Tcl index file\"\n"
800 "}\n"
801 "} msg]\n"
802 "if {[string compare $f \"\"]} {\n"
803 "close $f\n"
804 "}\n"
805 "if {$error} {\n"
806 "error $msg $errorInfo $errorCode\n"
807 "}\n"
808 "}\n"
809 "}\n"
810 "return 1\n"
811 "}\n"
812 "proc auto_qualify {cmd namespace} {\n"
813 "set n [regsub -all {::+} $cmd :: cmd]\n"
814 "if {[regexp {^::(.*)$} $cmd x tail]} {\n"
815 "if {$n > 1} {\n"
816 "return [list $cmd]\n"
817 "} else {\n"
818 "return [list $tail]\n"
819 "}\n"
820 "}\n"
821 "if {$n == 0} {\n"
822 "if {[string equal $namespace ::]} {\n"
823 "return [list $cmd]\n"
824 "} else {\n"
825 "return [list ${namespace}::$cmd $cmd]\n"
826 "}\n"
827 "} elseif {[string equal $namespace ::]} {\n"
828 "return [list ::$cmd]\n"
829 "} else {\n"
830 "return [list ${namespace}::$cmd ::$cmd]\n"
831 "}\n"
832 "}\n"
833 "proc auto_import {pattern} {\n"
834 "global auto_index\n"
835 "set ns [uplevel namespace current]\n"
836 "set patternList [auto_qualify $pattern $ns]\n"
837 "auto_load_index\n"
838 "foreach pattern $patternList {\n"
839 "foreach name [array names auto_index] {\n"
840 "if {[string match $pattern $name] && \\\n"
841 "\011\011 [string equal \"\" [info commands $name]]} {\n"
842 "uplevel #0 $auto_index($name)\n"
843 "}\n"
844 "}\n"
845 "}\n"
846 "}\n"
847 "if {[string equal windows $tcl_platform(platform)]} {\n"
848 "proc auto_execok name {\n"
849 "global auto_execs env tcl_platform\n"
850 "if {[info exists auto_execs($name)]} {\n"
851 "return $auto_execs($name)\n"
852 "}\n"
853 "set auto_execs($name) \"\"\n"
854 "set shellBuiltins [list cls copy date del erase dir echo mkdir \\\n"
855 "\011 md rename ren rmdir rd time type ver vol]\n"
856 "if {[string equal $tcl_platform(os) \"Windows NT\"]} {\n"
857 "lappend shellBuiltins \"start\"\n"
858 "}\n"
859 "if {[lsearch -exact $shellBuiltins $name] != -1} {\n"
860 "return [set auto_execs($name) [list $env(COMSPEC) /c $name]]\n"
861 "}\n"
862 "if {[llength [file split $name]] != 1} {\n"
863 "foreach ext {{} .com .exe .bat} {\n"
864 "set file ${name}${ext}\n"
865 "if {[file exists $file] && ![file isdirectory $file]} {\n"
866 "return [set auto_execs($name) [list $file]]\n"
867 "}\n"
868 "}\n"
869 "return \"\"\n"
870 "}\n"
871 "set path \"[file dirname [info nameof]];.;\"\n"
872 "if {[info exists env(WINDIR)]} {\n"
873 "set windir $env(WINDIR) \n"
874 "}\n"
875 "if {[info exists windir]} {\n"
876 "if {[string equal $tcl_platform(os) \"Windows NT\"]} {\n"
877 "append path \"$windir/system32;\"\n"
878 "}\n"
879 "append path \"$windir/system;$windir;\"\n"
880 "}\n"
881 "foreach var {PATH Path path} {\n"
882 "if {[info exists env($var)]} {\n"
883 "append path \";$env($var)\"\n"
884 "}\n"
885 "}\n"
886 "foreach dir [split $path {;}] {\n"
887 "if {[info exists checked($dir)] || [string equal {} $dir]} { continue }\n"
888 "set checked($dir) {}\n"
889 "foreach ext {{} .com .exe .bat} {\n"
890 "set file [file join $dir ${name}${ext}]\n"
891 "if {[file exists $file] && ![file isdirectory $file]} {\n"
892 "return [set auto_execs($name) [list $file]]\n"
893 "}\n"
894 "}\n"
895 "}\n"
896 "return \"\"\n"
897 "}\n"
898 "} else {\n"
899 "proc auto_execok name {\n"
900 "global auto_execs env\n"
901 "if {[info exists auto_execs($name)]} {\n"
902 "return $auto_execs($name)\n"
903 "}\n"
904 "set auto_execs($name) \"\"\n"
905 "if {[llength [file split $name]] != 1} {\n"
906 "if {[file executable $name] && ![file isdirectory $name]} {\n"
907 "set auto_execs($name) [list $name]\n"
908 "}\n"
909 "return $auto_execs($name)\n"
910 "}\n"
911 "foreach dir [split $env(PATH) :] {\n"
912 "if {[string equal $dir \"\"]} {\n"
913 "set dir .\n"
914 "}\n"
915 "set file [file join $dir $name]\n"
916 "if {[file executable $file] && ![file isdirectory $file]} {\n"
917 "set auto_execs($name) [list $file]\n"
918 "return $auto_execs($name)\n"
919 "}\n"
920 "}\n"
921 "return \"\"\n"
922 "}\n"
923 "}\n"
924 ;
925 static char Et_zFile3[] =
926 "namespace eval ::pkg {\n"
927 "}\n"
928 "proc pkg_compareExtension { fileName {ext {}} } {\n"
929 "global tcl_platform\n"
930 "if {[string length $ext] == 0} {\n"
931 "set ext [info sharedlibextension]\n"
932 "}\n"
933 "if {[string equal $tcl_platform(platform) \"windows\"]} {\n"
934 "return [string equal -nocase [file extension $fileName] $ext]\n"
935 "} else {\n"
936 "return [string equal [file extension $fileName] $ext]\n"
937 "}\n"
938 "}\n"
939 "proc pkg_mkIndex {args} {\n"
940 "global errorCode errorInfo\n"
941 "set usage {\"pkg_mkIndex ?-direct? ?-verbose? ?-load pattern? ?--? dir ?pattern ...?\"};\n"
942 "set argCount [llength $args]\n"
943 "if {$argCount < 1} {\n"
944 "return -code error \"wrong # args: should be\\n$usage\"\n"
945 "}\n"
946 "set more \"\"\n"
947 "set direct 1\n"
948 "set doVerbose 0\n"
949 "set loadPat \"\"\n"
950 "for {set idx 0} {$idx < $argCount} {incr idx} {\n"
951 "set flag [lindex $args $idx]\n"
952 "switch -glob -- $flag {\n"
953 "-- {\n"
954 "incr idx\n"
955 "break\n"
956 "}\n"
957 "-verbose {\n"
958 "set doVerbose 1\n"
959 "}\n"
960 "-lazy {\n"
961 "set direct 0\n"
962 "append more \" -lazy\"\n"
963 "}\n"
964 "-direct {\n"
965 "append more \" -direct\"\n"
966 "}\n"
967 "-load {\n"
968 "incr idx\n"
969 "set loadPat [lindex $args $idx]\n"
970 "append more \" -load $loadPat\"\n"
971 "}\n"
972 "-* {\n"
973 "return -code error \"unknown flag $flag: should be\\n$usage\"\n"
974 "}\n"
975 "default {\n"
976 "break\n"
977 "}\n"
978 "}\n"
979 "}\n"
980 "set dir [lindex $args $idx]\n"
981 "set patternList [lrange $args [expr {$idx + 1}] end]\n"
982 "if {[llength $patternList] == 0} {\n"
983 "set patternList [list \"*.tcl\" \"*[info sharedlibextension]\"]\n"
984 "}\n"
985 "set oldDir [pwd]\n"
986 "cd $dir\n"
987 "if {[catch {eval glob $patternList} fileList]} {\n"
988 "global errorCode errorInfo\n"
989 "cd $oldDir\n"
990 "return -code error -errorcode $errorCode -errorinfo $errorInfo $fileList\n"
991 "}\n"
992 "foreach file $fileList {\n"
993 "if {[string equal $file \"pkgIndex.tcl\"]} {\n"
994 "continue\n"
995 "}\n"
996 "cd $oldDir\n"
997 "set c [interp create]\n"
998 "foreach pkg [info loaded] {\n"
999 "if {! [string match $loadPat [lindex $pkg 1]]} {\n"
1000 "continue\n"
1001 "}\n"
1002 "if {[catch {\n"
1003 "load [lindex $pkg 0] [lindex $pkg 1] $c\n"
1004 "} err]} {\n"
1005 "if {$doVerbose} {\n"
1006 "tclLog \"warning: load [lindex $pkg 0] [lindex $pkg 1]\\nfailed with: $err\"\n"
1007 "}\n"
1008 "} elseif {$doVerbose} {\n"
1009 "tclLog \"loaded [lindex $pkg 0] [lindex $pkg 1]\"\n"
1010 "}\n"
1011 "if {[string equal [lindex $pkg 1] \"Tk\"]} {\n"
1012 "$c eval [list wm withdraw .]\n"
1013 "}\n"
1014 "}\n"
1015 "cd $dir\n"
1016 "$c eval {\n"
1017 "rename package __package_orig\n"
1018 "proc package {what args} {\n"
1019 "switch -- $what {\n"
1020 "require { return ; # ignore transitive requires }\n"
1021 "default { eval __package_orig {$what} $args }\n"
1022 "}\n"
1023 "}\n"
1024 "proc tclPkgUnknown args {}\n"
1025 "package unknown tclPkgUnknown\n"
1026 "proc unknown {args} {}\n"
1027 "proc auto_import {args} {}\n"
1028 "namespace eval ::tcl {\n"
1029 "variable file\011\011;# Current file being processed\n"
1030 "variable direct\011\011;# -direct flag value\n"
1031 "variable x\011\011;# Loop variable\n"
1032 "variable debug\011\011;# For debugging\n"
1033 "variable type\011\011;# \"load\" or \"source\", for -direct\n"
1034 "variable namespaces\011;# Existing namespaces (e.g., ::tcl)\n"
1035 "variable packages\011;# Existing packages (e.g., Tcl)\n"
1036 "variable origCmds\011;# Existing commands\n"
1037 "variable newCmds\011;# Newly created commands\n"
1038 "variable newPkgs {}\011;# Newly created packages\n"
1039 "}\n"
1040 "}\n"
1041 "$c eval [list set ::tcl::file $file]\n"
1042 "$c eval [list set ::tcl::direct $direct]\n"
1043 "foreach p {pkg_compareExtension} {\n"
1044 "$c eval [list proc $p [info args $p] [info body $p]]\n"
1045 "}\n"
1046 "if {[catch {\n"
1047 "$c eval {\n"
1048 "set ::tcl::debug \"loading or sourcing\"\n"
1049 "proc ::tcl::GetAllNamespaces {{root ::}} {\n"
1050 "set list $root\n"
1051 "foreach ns [namespace children $root] {\n"
1052 "eval lappend list [::tcl::GetAllNamespaces $ns]\n"
1053 "}\n"
1054 "return $list\n"
1055 "}\n"
1056 "foreach ::tcl::x [::tcl::GetAllNamespaces] {\n"
1057 "set ::tcl::namespaces($::tcl::x) 1\n"
1058 "}\n"
1059 "foreach ::tcl::x [package names] {\n"
1060 "set ::tcl::packages($::tcl::x) 1\n"
1061 "}\n"
1062 "set ::tcl::origCmds [info commands]\n"
1063 "if {[pkg_compareExtension $::tcl::file [info sharedlibextension]]} {\n"
1064 "set ::tcl::debug loading\n"
1065 "load [file join . $::tcl::file]\n"
1066 "set ::tcl::type load\n"
1067 "} else {\n"
1068 "set ::tcl::debug sourcing\n"
1069 "source $::tcl::file\n"
1070 "set ::tcl::type source\n"
1071 "}\n"
1072 "if { !$::tcl::direct } {\n"
1073 "foreach ::tcl::x [::tcl::GetAllNamespaces] {\n"
1074 "if {! [info exists ::tcl::namespaces($::tcl::x)]} {\n"
1075 "namespace import -force ${::tcl::x}::*\n"
1076 "}\n"
1077 "foreach ::tcl::x [info commands] {\n"
1078 "set ::tcl::newCmds($::tcl::x) 1\n"
1079 "}\n"
1080 "foreach ::tcl::x $::tcl::origCmds {\n"
1081 "catch {unset ::tcl::newCmds($::tcl::x)}\n"
1082 "}\n"
1083 "foreach ::tcl::x [array names ::tcl::newCmds] {\n"
1084 "set ::tcl::abs [namespace origin $::tcl::x]\n"
1085 "set ::tcl::abs \\\n"
1086 "\011\011\011\011 [lindex [auto_qualify $::tcl::abs ::] 0]\n"
1087 "if {[string compare $::tcl::x $::tcl::abs]} {\n"
1088 "set ::tcl::newCmds($::tcl::abs) 1\n"
1089 "unset ::tcl::newCmds($::tcl::x)\n"
1090 "}\n"
1091 "}\n"
1092 "}\n"
1093 "}\n"
1094 "foreach ::tcl::x [package names] {\n"
1095 "if {[string compare [package provide $::tcl::x] \"\"] \\\n"
1096 "\011\011\011 && ![info exists ::tcl::packages($::tcl::x)]} {\n"
1097 "lappend ::tcl::newPkgs \\\n"
1098 "\011\011\011 [list $::tcl::x [package provide $::tcl::x]]\n"
1099 "}\n"
1100 "}\n"
1101 "}\n"
1102 "} msg] == 1} {\n"
1103 "set what [$c eval set ::tcl::debug]\n"
1104 "if {$doVerbose} {\n"
1105 "tclLog \"warning: error while $what $file: $msg\"\n"
1106 "}\n"
1107 "} else {\n"
1108 "set type [$c eval set ::tcl::type]\n"
1109 "set cmds [lsort [$c eval array names ::tcl::newCmds]]\n"
1110 "set pkgs [$c eval set ::tcl::newPkgs]\n"
1111 "if {[llength $pkgs] > 1} {\n"
1112 "tclLog \"warning: \\\"$file\\\" provides more than one package ($pkgs)\"\n"
1113 "}\n"
1114 "foreach pkg $pkgs {\n"
1115 "lappend files($pkg) [list $file $type $cmds]\n"
1116 "}\n"
1117 "if {$doVerbose} {\n"
1118 "tclLog \"processed $file\"\n"
1119 "}\n"
1120 "interp delete $c\n"
1121 "}\n"
1122 "}\n"
1123 "append index \"# Tcl package index file, version 1.1\\n\"\n"
1124 "append index \"# This file is generated by the \\\"pkg_mkIndex$more\\\" command\\n\"\n"
1125 "append index \"# and sourced either when an application starts up or\\n\"\n"
1126 "append index \"# by a \\\"package unknown\\\" script. It invokes the\\n\"\n"
1127 "append index \"# \\\"package ifneeded\\\" command to set up package-related\\n\"\n"
1128 "append index \"# information so that packages will be loaded automatically\\n\"\n"
1129 "append index \"# in response to \\\"package require\\\" commands. When this\\n\"\n"
1130 "append index \"# script is sourced, the variable \\$dir must contain the\\n\"\n"
1131 "append index \"# full path name of this file's directory.\\n\"\n"
1132 "foreach pkg [lsort [array names files]] {\n"
1133 "set cmd {}\n"
1134 "foreach {name version} $pkg {\n"
1135 "break\n"
1136 "}\n"
1137 "lappend cmd ::pkg::create -name $name -version $version\n"
1138 "foreach spec $files($pkg) {\n"
1139 "foreach {file type procs} $spec {\n"
1140 "if { $direct } {\n"
1141 "set procs {}\n"
1142 "}\n"
1143 "lappend cmd \"-$type\" [list $file $procs]\n"
1144 "}\n"
1145 "}\n"
1146 "append index \"\\n[eval $cmd]\"\n"
1147 "}\n"
1148 "set f [open pkgIndex.tcl w]\n"
1149 "puts $f $index\n"
1150 "close $f\n"
1151 "cd $oldDir\n"
1152 "}\n"
1153 "proc tclPkgSetup {dir pkg version files} {\n"
1154 "global auto_index\n"
1155 "package provide $pkg $version\n"
1156 "foreach fileInfo $files {\n"
1157 "set f [lindex $fileInfo 0]\n"
1158 "set type [lindex $fileInfo 1]\n"
1159 "foreach cmd [lindex $fileInfo 2] {\n"
1160 "if {[string equal $type \"load\"]} {\n"
1161 "set auto_index($cmd) [list load [file join $dir $f] $pkg]\n"
1162 "} else {\n"
1163 "set auto_index($cmd) [list source [file join $dir $f]]\n"
1164 "} \n"
1165 "}\n"
1166 "}\n"
1167 "}\n"
1168 "proc tclMacPkgSearch {dir} {\n"
1169 "foreach x [glob -nocomplain [file join $dir *.shlb]] {\n"
1170 "if {[file isfile $x]} {\n"
1171 "set res [resource open $x]\n"
1172 "foreach y [resource list TEXT $res] {\n"
1173 "if {[string equal $y \"pkgIndex\"]} {source -rsrc pkgIndex}\n"
1174 "}\n"
1175 "catch {resource close $res}\n"
1176 "}\n"
1177 "}\n"
1178 "}\n"
1179 "proc tclPkgUnknown {name version {exact {}}} {\n"
1180 "global auto_path tcl_platform env\n"
1181 "if {![info exists auto_path]} {\n"
1182 "return\n"
1183 "}\n"
1184 "set old_path [set use_path $auto_path]\n"
1185 "while {[llength $use_path]} {\n"
1186 "set dir [lindex $use_path end]\n"
1187 "catch {\n"
1188 "foreach file [glob -nocomplain [file join $dir * pkgIndex.tcl]] {\n"
1189 "set dir [file dirname $file]\n"
1190 "if {[file readable $file] && ![info exists procdDirs($dir)]} {\n"
1191 "if {[catch {source $file} msg]} {\n"
1192 "tclLog \"error reading package index file $file: $msg\"\n"
1193 "} else {\n"
1194 "set procdDirs($dir) 1\n"
1195 "}\n"
1196 "}\n"
1197 "}\n"
1198 "}\n"
1199 "set dir [lindex $use_path end]\n"
1200 "set file [file join $dir pkgIndex.tcl]\n"
1201 "if {([interp issafe] || [file readable $file]) && \\\n"
1202 "\011\011![info exists procdDirs($dir)]} {\n"
1203 "if {[catch {source $file} msg] && ![interp issafe]} {\n"
1204 "tclLog \"error reading package index file $file: $msg\"\n"
1205 "} else {\n"
1206 "set procdDirs($dir) 1\n"
1207 "}\n"
1208 "}\n"
1209 "if {(![interp issafe]) && \\\n"
1210 "\011\011[string equal $tcl_platform(platform) \"macintosh\"]} {\n"
1211 "set dir [lindex $use_path end]\n"
1212 "if {![info exists procdDirs($dir)]} {\n"
1213 "tclMacPkgSearch $dir\n"
1214 "set procdDirs($dir) 1\n"
1215 "}\n"
1216 "foreach x [glob -nocomplain [file join $dir *]] {\n"
1217 "if {[file isdirectory $x] && ![info exists procdDirs($x)]} {\n"
1218 "set dir $x\n"
1219 "tclMacPkgSearch $dir\n"
1220 "set procdDirs($dir) 1\n"
1221 "}\n"
1222 "}\n"
1223 "}\n"
1224 "set use_path [lrange $use_path 0 end-1]\n"
1225 "if {[string compare $old_path $auto_path]} {\n"
1226 "foreach dir $auto_path {\n"
1227 "lappend use_path $dir\n"
1228 "}\n"
1229 "set old_path $auto_path\n"
1230 "}\n"
1231 "}\n"
1232 "}\n"
1233 "proc ::pkg::create {args} {\n"
1234 "append err(usage) \"[lindex [info level 0] 0] \"\n"
1235 "append err(usage) \"-name packageName -version packageVersion\"\n"
1236 "append err(usage) \"?-load {filename ?{procs}?}? ... \"\n"
1237 "append err(usage) \"?-source {filename ?{procs}?}? ...\"\n"
1238 "set err(wrongNumArgs) \"wrong # args: should be \\\"$err(usage)\\\"\"\n"
1239 "set err(valueMissing) \"value for \\\"%s\\\" missing: should be \\\"$err(usage)\\\"\"\n"
1240 "set err(unknownOpt) \"unknown option \\\"%s\\\": should be \\\"$err(usage)\\\"\"\n"
1241 "set err(noLoadOrSource) \"at least one of -load and -source must be given\"\n"
1242 "set len [llength $args]\n"
1243 "if { $len < 6 } {\n"
1244 "error $err(wrongNumArgs)\n"
1245 "}\n"
1246 "set opts(-name)\011\011{}\n"
1247 "set opts(-version)\011\011{}\n"
1248 "set opts(-source)\011\011{}\n"
1249 "set opts(-load)\011\011{}\n"
1250 "for {set i 0} {$i < $len} {incr i} {\n"
1251 "set flag [lindex $args $i]\n"
1252 "incr i\n"
1253 "switch -glob -- $flag {\n"
1254 "\"-name\"\011\011-\n"
1255 "\"-version\"\011\011{\n"
1256 "if { $i >= $len } {\n"
1257 "error [format $err(valueMissing) $flag]\n"
1258 "}\n"
1259 "set opts($flag) [lindex $args $i]\n"
1260 "}\n"
1261 "\"-source\"\011\011-\n"
1262 "\"-load\"\011\011{\n"
1263 "if { $i >= $len } {\n"
1264 "error [format $err(valueMissing) $flag]\n"
1265 "}\n"
1266 "lappend opts($flag) [lindex $args $i]\n"
1267 "}\n"
1268 "default {\n"
1269 "error [format $err(unknownOpt) [lindex $args $i]]\n"
1270 "}\n"
1271 "}\n"
1272 "}\n"
1273 "if { [llength $opts(-name)] == 0 } {\n"
1274 "error [format $err(valueMissing) \"-name\"]\n"
1275 "}\n"
1276 "if { [llength $opts(-version)] == 0 } {\n"
1277 "error [format $err(valueMissing) \"-version\"]\n"
1278 "}\n"
1279 "if { [llength $opts(-source)] == 0 && [llength $opts(-load)] == 0 } {\n"
1280 "error $err(noLoadOrSource)\n"
1281 "}\n"
1282 "set cmdline \"package ifneeded $opts(-name) $opts(-version) \"\n"
1283 "set cmdList {}\n"
1284 "set lazyFileList {}\n"
1285 "foreach key {load source} {\n"
1286 "foreach filespec $opts(-$key) {\n"
1287 "foreach {filename proclist} {{} {}} {\n"
1288 "break\n"
1289 "}\n"
1290 "foreach {filename proclist} $filespec {\n"
1291 "break\n"
1292 "}\n"
1293 "if { [llength $proclist] == 0 } {\n"
1294 "set cmd \"\\[list $key \\[file join \\$dir [list $filename]\\]\\]\"\n"
1295 "lappend cmdList $cmd\n"
1296 "} else {\n"
1297 "lappend lazyFileList [list $filename $key $proclist]\n"
1298 "}\n"
1299 "}\n"
1300 "}\n"
1301 "if { [llength $lazyFileList] > 0 } {\n"
1302 "lappend cmdList \"\\[list tclPkgSetup \\$dir $opts(-name)\\\n"
1303 "\011\011$opts(-version) [list $lazyFileList]\\]\"\n"
1304 "}\n"
1305 "append cmdline [join $cmdList \"\\\\n\"]\n"
1306 "return $cmdline\n"
1307 "}\n"
1308 ;
1309 static char Et_zFile4[] =
1310 "proc parray {a {pattern *}} {\n"
1311 "upvar 1 $a array\n"
1312 "if {![array exists array]} {\n"
1313 "error \"\\\"$a\\\" isn't an array\"\n"
1314 "}\n"
1315 "set maxl 0\n"
1316 "foreach name [lsort [array names array $pattern]] {\n"
1317 "if {[string length $name] > $maxl} {\n"
1318 "set maxl [string length $name]\n"
1319 "}\n"
1320 "}\n"
1321 "set maxl [expr {$maxl + [string length $a] + 2}]\n"
1322 "foreach name [lsort [array names array $pattern]] {\n"
1323 "set nameString [format %s(%s) $a $name]\n"
1324 "puts stdout [format \"%-*s = %s\" $maxl $nameString $array($name)]\n"
1325 "}\n"
1326 "}\n"
1327 ;
1328 static char Et_zFile5[] =
1329 "package require opt 0.4.1;\n"
1330 "namespace eval ::safe {\n"
1331 "namespace export interpCreate interpInit interpConfigure interpDelete \\\n"
1332 "\011 interpAddToAccessPath interpFindInAccessPath setLogCmd\n"
1333 "set temp [::tcl::OptKeyRegister {\n"
1334 "{-accessPath -list {} \"access path for the slave\"}\n"
1335 "{-noStatics \"prevent loading of statically linked pkgs\"}\n"
1336 "{-statics true \"loading of statically linked pkgs\"}\n"
1337 "{-nestedLoadOk \"allow nested loading\"}\n"
1338 "{-nested false \"nested loading\"}\n"
1339 "{-deleteHook -script {} \"delete hook\"}\n"
1340 "}]\n"
1341 "::tcl::OptKeyRegister {\n"
1342 "{?slave? -name {} \"name of the slave (optional)\"}\n"
1343 "} ::safe::interpCreate\n"
1344 "lappend ::tcl::OptDesc(::safe::interpCreate) $::tcl::OptDesc($temp)\n"
1345 "::tcl::OptKeyRegister {\n"
1346 "{slave -name {} \"name of the slave\"}\n"
1347 "} ::safe::interpIC\n"
1348 "lappend ::tcl::OptDesc(::safe::interpIC) $::tcl::OptDesc($temp)\n"
1349 "::tcl::OptKeyDelete $temp\n"
1350 "proc InterpStatics {} {\n"
1351 "foreach v {Args statics noStatics} {\n"
1352 "upvar $v $v\n"
1353 "}\n"
1354 "set flag [::tcl::OptProcArgGiven -noStatics];\n"
1355 "if {$flag && ($noStatics == $statics) \n"
1356 "&& ([::tcl::OptProcArgGiven -statics])} {\n"
1357 "return -code error\\\n"
1358 "\011\011 \"conflicting values given for -statics and -noStatics\"\n"
1359 "}\n"
1360 "if {$flag} {\n"
1361 "return [expr {!$noStatics}]\n"
1362 "} else {\n"
1363 "return $statics\n"
1364 "}\n"
1365 "}\n"
1366 "proc InterpNested {} {\n"
1367 "foreach v {Args nested nestedLoadOk} {\n"
1368 "upvar $v $v\n"
1369 "}\n"
1370 "set flag [::tcl::OptProcArgGiven -nestedLoadOk];\n"
1371 "if {$flag && ($nestedLoadOk != $nested) \n"
1372 "&& ([::tcl::OptProcArgGiven -nested])} {\n"
1373 "return -code error\\\n"
1374 "\011\011 \"conflicting values given for -nested and -nestedLoadOk\"\n"
1375 "}\n"
1376 "if {$flag} {\n"
1377 "return $nestedLoadOk\n"
1378 "} else {\n"
1379 "return $nested\n"
1380 "}\n"
1381 "}\n"
1382 "proc interpCreate {args} {\n"
1383 "set Args [::tcl::OptKeyParse ::safe::interpCreate $args]\n"
1384 "InterpCreate $slave $accessPath \\\n"
1385 "\011\011[InterpStatics] [InterpNested] $deleteHook\n"
1386 "}\n"
1387 "proc interpInit {args} {\n"
1388 "set Args [::tcl::OptKeyParse ::safe::interpIC $args]\n"
1389 "if {![::interp exists $slave]} {\n"
1390 "return -code error \"\\\"$slave\\\" is not an interpreter\"\n"
1391 "}\n"
1392 "InterpInit $slave $accessPath \\\n"
1393 "\011\011[InterpStatics] [InterpNested] $deleteHook;\n"
1394 "}\n"
1395 "proc CheckInterp {slave} {\n"
1396 "if {![IsInterp $slave]} {\n"
1397 "return -code error \\\n"
1398 "\011\011 \"\\\"$slave\\\" is not an interpreter managed by ::safe::\"\n"
1399 "}\n"
1400 "}\n"
1401 "proc interpConfigure {args} {\n"
1402 "switch [llength $args] {\n"
1403 "1 {\n"
1404 "set Args [::tcl::OptKeyParse ::safe::interpIC $args]\n"
1405 "CheckInterp $slave\n"
1406 "set res {}\n"
1407 "lappend res [list -accessPath [Set [PathListName $slave]]]\n"
1408 "lappend res [list -statics [Set [StaticsOkName $slave]]]\n"
1409 "lappend res [list -nested [Set [NestedOkName $slave]]]\n"
1410 "lappend res [list -deleteHook [Set [DeleteHookName $slave]]]\n"
1411 "join $res\n"
1412 "}\n"
1413 "2 {\n"
1414 "::tcl::Lassign $args slave arg\n"
1415 "set desc [lindex [::tcl::OptKeyGetDesc ::safe::interpIC] 2]\n"
1416 "set hits [::tcl::OptHits desc $arg]\n"
1417 "if {$hits > 1} {\n"
1418 "return -code error [::tcl::OptAmbigous $desc $arg]\n"
1419 "} elseif {$hits == 0} {\n"
1420 "return -code error [::tcl::OptFlagUsage $desc $arg]\n"
1421 "}\n"
1422 "CheckInterp $slave\n"
1423 "set item [::tcl::OptCurDesc $desc]\n"
1424 "set name [::tcl::OptName $item]\n"
1425 "switch -exact -- $name {\n"
1426 "-accessPath {\n"
1427 "return [list -accessPath [Set [PathListName $slave]]]\n"
1428 "}\n"
1429 "-statics {\n"
1430 "return [list -statics [Set [StaticsOkName $slave]]]\n"
1431 "}\n"
1432 "-nested {\n"
1433 "return [list -nested [Set [NestedOkName $slave]]]\n"
1434 "}\n"
1435 "-deleteHook {\n"
1436 "return [list -deleteHook [Set [DeleteHookName $slave]]]\n"
1437 "}\n"
1438 "-noStatics {\n"
1439 "return -code error\\\n"
1440 "\011\011\011\011\"ambigous query (get or set -noStatics ?)\\\n"
1441 "\011\011\011\011use -statics instead\"\n"
1442 "}\n"
1443 "-nestedLoadOk {\n"
1444 "return -code error\\\n"
1445 "\011\011\011\011\"ambigous query (get or set -nestedLoadOk ?)\\\n"
1446 "\011\011\011\011use -nested instead\"\n"
1447 "}\n"
1448 "default {\n"
1449 "return -code error \"unknown flag $name (bug)\"\n"
1450 "}\n"
1451 "}\n"
1452 "}\n"
1453 "default {\n"
1454 "set Args [::tcl::OptKeyParse ::safe::interpIC $args]\n"
1455 "CheckInterp $slave\n"
1456 "if {![::tcl::OptProcArgGiven -accessPath]} {\n"
1457 "set doreset 1\n"
1458 "set accessPath [Set [PathListName $slave]]\n"
1459 "} else {\n"
1460 "set doreset 0\n"
1461 "}\n"
1462 "if {(![::tcl::OptProcArgGiven -statics]) \\\n"
1463 "\011\011\011&& (![::tcl::OptProcArgGiven -noStatics]) } {\n"
1464 "set statics [Set [StaticsOkName $slave]]\n"
1465 "} else {\n"
1466 "set statics [InterpStatics]\n"
1467 "}\n"
1468 "if {([::tcl::OptProcArgGiven -nested]) \\\n"
1469 "\011\011\011|| ([::tcl::OptProcArgGiven -nestedLoadOk]) } {\n"
1470 "set nested [InterpNested]\n"
1471 "} else {\n"
1472 "set nested [Set [NestedOkName $slave]]\n"
1473 "}\n"
1474 "if {![::tcl::OptProcArgGiven -deleteHook]} {\n"
1475 "set deleteHook [Set [DeleteHookName $slave]]\n"
1476 "}\n"
1477 "InterpSetConfig $slave $accessPath $statics $nested $deleteHook\n"
1478 "if {$doreset} {\n"
1479 "if {[catch {::interp eval $slave {auto_reset}} msg]} {\n"
1480 "Log $slave \"auto_reset failed: $msg\"\n"
1481 "} else {\n"
1482 "Log $slave \"successful auto_reset\" NOTICE\n"
1483 "}\n"
1484 "}\n"
1485 "}\n"
1486 "}\n"
1487 "}\n"
1488 "proc ::safe::InterpCreate {\n"
1489 "slave \n"
1490 "access_path\n"
1491 "staticsok\n"
1492 "nestedok\n"
1493 "deletehook\n"
1494 "} {\n"
1495 "if {[string compare \"\" $slave]} {\n"
1496 "::interp create -safe $slave\n"
1497 "} else {\n"
1498 "set slave [::interp create -safe]\n"
1499 "}\n"
1500 "Log $slave \"Created\" NOTICE\n"
1501 "InterpInit $slave $access_path $staticsok $nestedok $deletehook\n"
1502 "}\n"
1503 "proc ::safe::InterpSetConfig {slave access_path staticsok\\\n"
1504 "\011 nestedok deletehook} {\n"
1505 "if {[string equal \"\" $access_path]} {\n"
1506 "set access_path [uplevel #0 set auto_path]\n"
1507 "set where [lsearch -exact $access_path [info library]]\n"
1508 "if {$where == -1} {\n"
1509 "set access_path [concat [list [info library]] $access_path]\n"
1510 "Log $slave \"tcl_library was not in auto_path,\\\n"
1511 "\011\011\011added it to slave's access_path\" NOTICE\n"
1512 "} elseif {$where != 0} {\n"
1513 "set access_path [concat [list [info library]]\\\n"
1514 "\011\011\011[lreplace $access_path $where $where]]\n"
1515 "Log $slave \"tcl_libray was not in first in auto_path,\\\n"
1516 "\011\011\011moved it to front of slave's access_path\" NOTICE\n"
1517 "}\n"
1518 "set access_path [AddSubDirs $access_path]\n"
1519 "}\n"
1520 "Log $slave \"Setting accessPath=($access_path) staticsok=$staticsok\\\n"
1521 "\011\011nestedok=$nestedok deletehook=($deletehook)\" NOTICE\n"
1522 "set nname [PathNumberName $slave]\n"
1523 "if {[Exists $nname]} {\n"
1524 "set n [Set $nname]\n"
1525 "for {set i 0} {$i<$n} {incr i} {\n"
1526 "Unset [PathToken $i $slave]\n"
1527 "}\n"
1528 "}\n"
1529 "set slave_auto_path {}\n"
1530 "set i 0\n"
1531 "foreach dir $access_path {\n"
1532 "Set [PathToken $i $slave] $dir\n"
1533 "lappend slave_auto_path \"\\$[PathToken $i]\"\n"
1534 "incr i\n"
1535 "}\n"
1536 "Set $nname $i\n"
1537 "Set [PathListName $slave] $access_path\n"
1538 "Set [VirtualPathListName $slave] $slave_auto_path\n"
1539 "Set [StaticsOkName $slave] $staticsok\n"
1540 "Set [NestedOkName $slave] $nestedok\n"
1541 "Set [DeleteHookName $slave] $deletehook\n"
1542 "SyncAccessPath $slave\n"
1543 "}\n"
1544 "proc ::safe::interpFindInAccessPath {slave path} {\n"
1545 "set access_path [GetAccessPath $slave]\n"
1546 "set where [lsearch -exact $access_path $path]\n"
1547 "if {$where == -1} {\n"
1548 "return -code error \"$path not found in access path $access_path\"\n"
1549 "}\n"
1550 "return \"\\$[PathToken $where]\"\n"
1551 "}\n"
1552 "proc ::safe::interpAddToAccessPath {slave path} {\n"
1553 "if {![catch {interpFindInAccessPath $slave $path} res]} {\n"
1554 "return $res\n"
1555 "}\n"
1556 "set nname [PathNumberName $slave]\n"
1557 "set n [Set $nname]\n"
1558 "Set [PathToken $n $slave] $path\n"
1559 "set token \"\\$[PathToken $n]\"\n"
1560 "Lappend [VirtualPathListName $slave] $token\n"
1561 "Lappend [PathListName $slave] $path\n"
1562 "Set $nname [expr {$n+1}]\n"
1563 "SyncAccessPath $slave\n"
1564 "return $token\n"
1565 "}\n"
1566 "proc ::safe::InterpInit {\n"
1567 "slave \n"
1568 "access_path\n"
1569 "staticsok\n"
1570 "nestedok\n"
1571 "deletehook\n"
1572 "} {\n"
1573 "InterpSetConfig $slave $access_path $staticsok $nestedok $deletehook\n"
1574 "::interp alias $slave source {} [namespace current]::AliasSource $slave\n"
1575 "::interp alias $slave load {} [namespace current]::AliasLoad $slave\n"
1576 "::interp alias $slave encoding {} [namespace current]::AliasEncoding \\\n"
1577 "\011\011$slave\n"
1578 "AliasSubset $slave file file dir.* join root.* ext.* tail \\\n"
1579 "\011\011path.* split\n"
1580 "::interp alias $slave exit {} [namespace current]::interpDelete $slave\n"
1581 "if {[catch {::interp eval $slave\\\n"
1582 "\011\011{source [file join $tcl_library init.tcl]}} msg]} {\n"
1583 "Log $slave \"can't source init.tcl ($msg)\"\n"
1584 "error \"can't source init.tcl into slave $slave ($msg)\"\n"
1585 "}\n"
1586 "return $slave\n"
1587 "}\n"
1588 "proc AddSubDirs {pathList} {\n"
1589 "set res {}\n"
1590 "foreach dir $pathList {\n"
1591 "if {[file isdirectory $dir]} {\n"
1592 "if {[lsearch -exact $res $dir]<0} {\n"
1593 "lappend res $dir\n"
1594 "}\n"
1595 "foreach sub [glob -nocomplain -- [file join $dir *]] {\n"
1596 "if {([file isdirectory $sub]) \\\n"
1597 "\011\011\011 && ([lsearch -exact $res $sub]<0) } {\n"
1598 "lappend res $sub\n"
1599 "}\n"
1600 "}\n"
1601 "}\n"
1602 "}\n"
1603 "return $res\n"
1604 "}\n"
1605 "proc ::safe::interpDelete {slave} {\n"
1606 "Log $slave \"About to delete\" NOTICE\n"
1607 "set hookname [DeleteHookName $slave]\n"
1608 "if {[Exists $hookname]} {\n"
1609 "set hook [Set $hookname]\n"
1610 "if {![::tcl::Lempty $hook]} {\n"
1611 "Unset $hookname\n"
1612 "if {[catch {eval $hook [list $slave]} err]} {\n"
1613 "Log $slave \"Delete hook error ($err)\"\n"
1614 "}\n"
1615 "}\n"
1616 "}\n"
1617 "set statename [InterpStateName $slave]\n"
1618 "if {[Exists $statename]} {\n"
1619 "Unset $statename\n"
1620 "}\n"
1621 "if {[::interp exists $slave]} {\n"
1622 "::interp delete $slave\n"
1623 "Log $slave \"Deleted\" NOTICE\n"
1624 "}\n"
1625 "return\n"
1626 "}\n"
1627 "proc ::safe::setLogCmd {args} {\n"
1628 "variable Log\n"
1629 "if {[llength $args] == 0} {\n"
1630 "return $Log\n"
1631 "} else {\n"
1632 "if {[llength $args] == 1} {\n"
1633 "set Log [lindex $args 0]\n"
1634 "} else {\n"
1635 "set Log $args\n"
1636 "}\n"
1637 "}\n"
1638 "}\n"
1639 "variable Log {}\n"
1640 "proc SyncAccessPath {slave} {\n"
1641 "set slave_auto_path [Set [VirtualPathListName $slave]]\n"
1642 "::interp eval $slave [list set auto_path $slave_auto_path]\n"
1643 "Log $slave \"auto_path in $slave has been set to $slave_auto_path\"\\\n"
1644 "\011\011NOTICE\n"
1645 "::interp eval $slave [list set tcl_library [lindex $slave_auto_path 0]]\n"
1646 "}\n"
1647 "proc InterpStateName {slave} {\n"
1648 "return \"S$slave\"\n"
1649 "}\n"
1650 "proc IsInterp {slave} {\n"
1651 "expr {[Exists [InterpStateName $slave]] && [::interp exists $slave]}\n"
1652 "}\n"
1653 "proc PathToken {n {slave \"\"}} {\n"
1654 "if {[string compare \"\" $slave]} {\n"
1655 "return \"[InterpStateName $slave](access_path,$n)\"\n"
1656 "} else {\n"
1657 "return \"p(:$n:)\"\n"
1658 "}\n"
1659 "}\n"
1660 "proc PathListName {slave} {\n"
1661 "return \"[InterpStateName $slave](access_path)\"\n"
1662 "}\n"
1663 "proc VirtualPathListName {slave} {\n"
1664 "return \"[InterpStateName $slave](access_path_slave)\"\n"
1665 "}\n"
1666 "proc PathNumberName {slave} {\n"
1667 "return \"[InterpStateName $slave](access_path,n)\"\n"
1668 "}\n"
1669 "proc StaticsOkName {slave} {\n"
1670 "return \"[InterpStateName $slave](staticsok)\"\n"
1671 "}\n"
1672 "proc NestedOkName {slave} {\n"
1673 "return \"[InterpStateName $slave](nestedok)\"\n"
1674 "}\n"
1675 "proc Toplevel {args} {\n"
1676 "namespace eval [namespace current] $args\n"
1677 "}\n"
1678 "proc Set {args} {\n"
1679 "eval Toplevel set $args\n"
1680 "}\n"
1681 "proc Lappend {args} {\n"
1682 "eval Toplevel lappend $args\n"
1683 "}\n"
1684 "proc Unset {args} {\n"
1685 "eval Toplevel unset $args\n"
1686 "}\n"
1687 "proc Exists {varname} {\n"
1688 "Toplevel info exists $varname\n"
1689 "}\n"
1690 "proc GetAccessPath {slave} {\n"
1691 "Set [PathListName $slave]\n"
1692 "}\n"
1693 "proc StaticsOk {slave} {\n"
1694 "Set [StaticsOkName $slave]\n"
1695 "}\n"
1696 "proc NestedOk {slave} {\n"
1697 "Set [NestedOkName $slave]\n"
1698 "}\n"
1699 "proc DeleteHookName {slave} {\n"
1700 "return [InterpStateName $slave](cleanupHook)\n"
1701 "}\n"
1702 "proc TranslatePath {slave path} {\n"
1703 "if {[regexp {(::)|(\\.\\.)} $path]} {\n"
1704 "error \"invalid characters in path $path\"\n"
1705 "}\n"
1706 "set n [expr {[Set [PathNumberName $slave]]-1}]\n"
1707 "for {} {$n>=0} {incr n -1} {\n"
1708 "set [PathToken $n] [Set [PathToken $n $slave]]\n"
1709 "}\n"
1710 "subst -nobackslashes -nocommands $path\n"
1711 "}\n"
1712 "proc Log {slave msg {type ERROR}} {\n"
1713 "variable Log\n"
1714 "if {[info exists Log] && [llength $Log]} {\n"
1715 "eval $Log [list \"$type for slave $slave : $msg\"]\n"
1716 "}\n"
1717 "}\n"
1718 "proc CheckFileName {slave file} {\n"
1719 "set ftail [file tail $file]\n"
1720 "if {[string length $ftail]>14} {\n"
1721 "error \"$ftail: filename too long\"\n"
1722 "}\n"
1723 "if {[regexp {\\..*\\.} $ftail]} {\n"
1724 "error \"$ftail: more than one dot is forbidden\"\n"
1725 "}\n"
1726 "if {[string compare $ftail \"tclIndex\"] && \\\n"
1727 "\011\011[string compare -nocase [file extension $ftail]\011\".tcl\"]} {\n"
1728 "error \"$ftail: must be a *.tcl or tclIndex\"\n"
1729 "}\n"
1730 "if {![file exists $file]} {\n"
1731 "error \"no such file or directory\"\n"
1732 "}\n"
1733 "if {![file readable $file]} {\n"
1734 "error \"not readable\"\n"
1735 "}\n"
1736 "}\n"
1737 "proc AliasSource {slave args} {\n"
1738 "set argc [llength $args]\n"
1739 "if {$argc != 1} {\n"
1740 "set msg \"wrong # args: should be \\\"source fileName\\\"\"\n"
1741 "Log $slave \"$msg ($args)\"\n"
1742 "return -code error $msg\n"
1743 "}\n"
1744 "set file [lindex $args 0]\n"
1745 "if {[catch {set file [TranslatePath $slave $file]} msg]} {\n"
1746 "Log $slave $msg\n"
1747 "return -code error \"permission denied\"\n"
1748 "}\n"
1749 "if {[catch {FileInAccessPath $slave $file} msg]} {\n"
1750 "Log $slave $msg\n"
1751 "return -code error \"permission denied\"\n"
1752 "}\n"
1753 "if {[catch {CheckFileName $slave $file} msg]} {\n"
1754 "Log $slave \"$file:$msg\"\n"
1755 "return -code error $msg\n"
1756 "}\n"
1757 "if {[catch {::interp invokehidden $slave source $file} msg]} {\n"
1758 "Log $slave $msg\n"
1759 "return -code error \"script error\"\n"
1760 "}\n"
1761 "return $msg\n"
1762 "}\n"
1763 "proc AliasLoad {slave file args} {\n"
1764 "set argc [llength $args]\n"
1765 "if {$argc > 2} {\n"
1766 "set msg \"load error: too many arguments\"\n"
1767 "Log $slave \"$msg ($argc) {$file $args}\"\n"
1768 "return -code error $msg\n"
1769 "}\n"
1770 "set package [lindex $args 0]\n"
1771 "set target [lindex $args 1]\n"
1772 "if {[string length $target]} {\n"
1773 "if {![NestedOk $slave]} {\n"
1774 "Log $slave \"loading to a sub interp (nestedok)\\\n"
1775 "\011\011\011disabled (trying to load $package to $target)\"\n"
1776 "return -code error \"permission denied (nested load)\"\n"
1777 "}\n"
1778 "}\n"
1779 "if {[string length $file] == 0} {\n"
1780 "if {[string length $package] == 0} {\n"
1781 "set msg \"load error: empty filename and no package name\"\n"
1782 "Log $slave $msg\n"
1783 "return -code error $msg\n"
1784 "}\n"
1785 "if {![StaticsOk $slave]} {\n"
1786 "Log $slave \"static packages loading disabled\\\n"
1787 "\011\011\011(trying to load $package to $target)\"\n"
1788 "return -code error \"permission denied (static package)\"\n"
1789 "}\n"
1790 "} else {\n"
1791 "if {[catch {set file [TranslatePath $slave $file]} msg]} {\n"
1792 "Log $slave $msg\n"
1793 "return -code error \"permission denied\"\n"
1794 "}\n"
1795 "if {[catch {FileInAccessPath $slave $file} msg]} {\n"
1796 "Log $slave $msg\n"
1797 "return -code error \"permission denied (path)\"\n"
1798 "}\n"
1799 "}\n"
1800 "if {[catch {::interp invokehidden\\\n"
1801 "\011\011$slave load $file $package $target} msg]} {\n"
1802 "Log $slave $msg\n"
1803 "return -code error $msg\n"
1804 "}\n"
1805 "return $msg\n"
1806 "}\n"
1807 "proc FileInAccessPath {slave file} {\n"
1808 "set access_path [GetAccessPath $slave]\n"
1809 "if {[file isdirectory $file]} {\n"
1810 "error \"\\\"$file\\\": is a directory\"\n"
1811 "}\n"
1812 "set parent [file dirname $file]\n"
1813 "if {[lsearch -exact $access_path $parent] == -1} {\n"
1814 "error \"\\\"$file\\\": not in access_path\"\n"
1815 "}\n"
1816 "}\n"
1817 "proc Subset {slave command okpat args} {\n"
1818 "set subcommand [lindex $args 0]\n"
1819 "if {[regexp $okpat $subcommand]} {\n"
1820 "return [eval {$command $subcommand} [lrange $args 1 end]]\n"
1821 "}\n"
1822 "set msg \"not allowed to invoke subcommand $subcommand of $command\"\n"
1823 "Log $slave $msg\n"
1824 "error $msg\n"
1825 "}\n"
1826 "proc AliasSubset {slave alias target args} {\n"
1827 "set pat ^(; set sep \"\"\n"
1828 "foreach sub $args {\n"
1829 "append pat $sep$sub\n"
1830 "set sep |\n"
1831 "}\n"
1832 "append pat )\\$\n"
1833 "::interp alias $slave $alias {}\\\n"
1834 "\011\011[namespace current]::Subset $slave $target $pat\n"
1835 "}\n"
1836 "proc AliasEncoding {slave args} {\n"
1837 "set argc [llength $args]\n"
1838 "set okpat \"^(name.*|convert.*)\\$\"\n"
1839 "set subcommand [lindex $args 0]\n"
1840 "if {[regexp $okpat $subcommand]} {\n"
1841 "return [eval ::interp invokehidden $slave encoding $subcommand \\\n"
1842 "\011\011 [lrange $args 1 end]]\n"
1843 "}\n"
1844 "if {[string match $subcommand system]} {\n"
1845 "if {$argc == 1} {\n"
1846 "if {[catch {::interp invokehidden \\\n"
1847 "\011\011\011$slave encoding system} msg]} {\n"
1848 "Log $slave $msg\n"
1849 "return -code error \"script error\"\n"
1850 "}\n"
1851 "} else {\n"
1852 "set msg \"wrong # args: should be \\\"encoding system\\\"\"\n"
1853 "Log $slave $msg\n"
1854 "error $msg\n"
1855 "}\n"
1856 "} else {\n"
1857 "set msg \"wrong # args: should be \\\"encoding option ?arg ...?\\\"\"\n"
1858 "Log $slave $msg\n"
1859 "error $msg\n"
1860 "}\n"
1861 "return $msg\n"
1862 "}\n"
1863 "}\n"
1864 ;
1865 static char Et_zFile6[] =
1866 "# Tcl autoload index file, version 2.0\n"
1867 "# This file is generated by the \"auto_mkindex\" command\n"
1868 "# and sourced to set up indexing information for one or\n"
1869 "# more commands. Typically each line is a command that\n"
1870 "# sets an element in the auto_index array, where the\n"
1871 "# element name is the name of a command and the value is\n"
1872 "# a script that loads the command.\n"
1873 "\n"
1874 "set auto_index(auto_reset) [list source [file join $dir auto.tcl]]\n"
1875 "set auto_index(tcl_findLibrary) [list source [file join $dir auto.tcl]]\n"
1876 "set auto_index(auto_mkindex) [list source [file join $dir auto.tcl]]\n"
1877 "set auto_index(auto_mkindex_old) [list source [file join $dir auto.tcl]]\n"
1878 "set auto_index(::auto_mkindex_parser::init) [list source [file join $dir auto.tcl]]\n"
1879 "set auto_index(::auto_mkindex_parser::cleanup) [list source [file join $dir auto.tcl]]\n"
1880 "set auto_index(::auto_mkindex_parser::mkindex) [list source [file join $dir auto.tcl]]\n"
1881 "set auto_index(::auto_mkindex_parser::hook) [list source [file join $dir auto.tcl]]\n"
1882 "set auto_index(::auto_mkindex_parser::slavehook) [list source [file join $dir auto.tcl]]\n"
1883 "set auto_index(::auto_mkindex_parser::command) [list source [file join $dir auto.tcl]]\n"
1884 "set auto_index(::auto_mkindex_parser::commandInit) [list source [file join $dir auto.tcl]]\n"
1885 "set auto_index(::auto_mkindex_parser::fullname) [list source [file join $dir auto.tcl]]\n"
1886 "set auto_index(history) [list source [file join $dir history.tcl]]\n"
1887 "set auto_index(::tcl::HistAdd) [list source [file join $dir history.tcl]]\n"
1888 "set auto_index(::tcl::HistKeep) [list source [file join $dir history.tcl]]\n"
1889 "set auto_index(::tcl::HistClear) [list source [file join $dir history.tcl]]\n"
1890 "set auto_index(::tcl::HistInfo) [list source [file join $dir history.tcl]]\n"
1891 "set auto_index(::tcl::HistRedo) [list source [file join $dir history.tcl]]\n"
1892 "set auto_index(::tcl::HistIndex) [list source [file join $dir history.tcl]]\n"
1893 "set auto_index(::tcl::HistEvent) [list source [file join $dir history.tcl]]\n"
1894 "set auto_index(::tcl::HistChange) [list source [file join $dir history.tcl]]\n"
1895 "set auto_index(tclLdAout) [list source [file join $dir ldAout.tcl]]\n"
1896 "set auto_index(pkg_compareExtension) [list source [file join $dir package.tcl]]\n"
1897 "set auto_index(pkg_mkIndex) [list source [file join $dir package.tcl]]\n"
1898 "set auto_index(tclPkgSetup) [list source [file join $dir package.tcl]]\n"
1899 "set auto_index(tclMacPkgSearch) [list source [file join $dir package.tcl]]\n"
1900 "set auto_index(tclPkgUnknown) [list source [file join $dir package.tcl]]\n"
1901 "set auto_index(::pkg::create) [list source [file join $dir package.tcl]]\n"
1902 "set auto_index(parray) [list source [file join $dir parray.tcl]]\n"
1903 "set auto_index(::safe::InterpStatics) [list source [file join $dir safe.tcl]]\n"
1904 "set auto_index(::safe::InterpNested) [list source [file join $dir safe.tcl]]\n"
1905 "set auto_index(::safe::interpCreate) [list source [file join $dir safe.tcl]]\n"
1906 "set auto_index(::safe::interpInit) [list source [file join $dir safe.tcl]]\n"
1907 "set auto_index(::safe::CheckInterp) [list source [file join $dir safe.tcl]]\n"
1908 "set auto_index(::safe::interpConfigure) [list source [file join $dir safe.tcl]]\n"
1909 "set auto_index(::safe::InterpCreate) [list source [file join $dir safe.tcl]]\n"
1910 "set auto_index(::safe::InterpSetConfig) [list source [file join $dir safe.tcl]]\n"
1911 "set auto_index(::safe::interpFindInAccessPath) [list source [file join $dir safe.tcl]]\n"
1912 "set auto_index(::safe::interpAddToAccessPath) [list source [file join $dir safe.tcl]]\n"
1913 "set auto_index(::safe::InterpInit) [list source [file join $dir safe.tcl]]\n"
1914 "set auto_index(::safe::AddSubDirs) [list source [file join $dir safe.tcl]]\n"
1915 "set auto_index(::safe::interpDelete) [list source [file join $dir safe.tcl]]\n"
1916 "set auto_index(::safe::setLogCmd) [list source [file join $dir safe.tcl]]\n"
1917 "set auto_index(::safe::SyncAccessPath) [list source [file join $dir safe.tcl]]\n"
1918 "set auto_index(::safe::InterpStateName) [list source [file join $dir safe.tcl]]\n"
1919 "set auto_index(::safe::IsInterp) [list source [file join $dir safe.tcl]]\n"
1920 "set auto_index(::safe::PathToken) [list source [file join $dir safe.tcl]]\n"
1921 "set auto_index(::safe::PathListName) [list source [file join $dir safe.tcl]]\n"
1922 "set auto_index(::safe::VirtualPathListName) [list source [file join $dir safe.tcl]]\n"
1923 "set auto_index(::safe::PathNumberName) [list source [file join $dir safe.tcl]]\n"
1924 "set auto_index(::safe::StaticsOkName) [list source [file join $dir safe.tcl]]\n"
1925 "set auto_index(::safe::NestedOkName) [list source [file join $dir safe.tcl]]\n"
1926 "set auto_index(::safe::Toplevel) [list source [file join $dir safe.tcl]]\n"
1927 "set auto_index(::safe::Set) [list source [file join $dir safe.tcl]]\n"
1928 "set auto_index(::safe::Lappend) [list source [file join $dir safe.tcl]]\n"
1929 "set auto_index(::safe::Unset) [list source [file join $dir safe.tcl]]\n"
1930 "set auto_index(::safe::Exists) [list source [file join $dir safe.tcl]]\n"
1931 "set auto_index(::safe::GetAccessPath) [list source [file join $dir safe.tcl]]\n"
1932 "set auto_index(::safe::StaticsOk) [list source [file join $dir safe.tcl]]\n"
1933 "set auto_index(::safe::NestedOk) [list source [file join $dir safe.tcl]]\n"
1934 "set auto_index(::safe::DeleteHookName) [list source [file join $dir safe.tcl]]\n"
1935 "set auto_index(::safe::TranslatePath) [list source [file join $dir safe.tcl]]\n"
1936 "set auto_index(::safe::Log) [list source [file join $dir safe.tcl]]\n"
1937 "set auto_index(::safe::CheckFileName) [list source [file join $dir safe.tcl]]\n"
1938 "set auto_index(::safe::AliasSource) [list source [file join $dir safe.tcl]]\n"
1939 "set auto_index(::safe::AliasLoad) [list source [file join $dir safe.tcl]]\n"
1940 "set auto_index(::safe::FileInAccessPath) [list source [file join $dir safe.tcl]]\n"
1941 "set auto_index(::safe::Subset) [list source [file join $dir safe.tcl]]\n"
1942 "set auto_index(::safe::AliasSubset) [list source [file join $dir safe.tcl]]\n"
1943 "set auto_index(tcl_wordBreakAfter) [list source [file join $dir word.tcl]]\n"
1944 "set auto_index(tcl_wordBreakBefore) [list source [file join $dir word.tcl]]\n"
1945 "set auto_index(tcl_endOfWord) [list source [file join $dir word.tcl]]\n"
1946 "set auto_index(tcl_startOfNextWord) [list source [file join $dir word.tcl]]\n"
1947 "set auto_index(tcl_startOfPreviousWord) [list source [file join $dir word.tcl]]\n"
1948 ;
1949 static char Et_zFile7[] =
1950 "if {[string equal $tcl_platform(platform) \"windows\"]} {\n"
1951 "set tcl_wordchars \"\\\\S\"\n"
1952 "set tcl_nonwordchars \"\\\\s\"\n"
1953 "} else {\n"
1954 "set tcl_wordchars \"\\\\w\"\n"
1955 "set tcl_nonwordchars \"\\\\W\"\n"
1956 "}\n"
1957 "proc tcl_wordBreakAfter {str start} {\n"
1958 "global tcl_nonwordchars tcl_wordchars\n"
1959 "set str [string range $str $start end]\n"
1960 "if {[regexp -indices \"$tcl_wordchars$tcl_nonwordchars|$tcl_nonwordchars$tcl_wordchars\" $str result]} {\n"
1961 "return [expr {[lindex $result 1] + $start}]\n"
1962 "}\n"
1963 "return -1\n"
1964 "}\n"
1965 "proc tcl_wordBreakBefore {str start} {\n"
1966 "global tcl_nonwordchars tcl_wordchars\n"
1967 "if {[string equal $start end]} {\n"
1968 "set start [string length $str]\n"
1969 "}\n"
1970 "if {[regexp -indices \"^.*($tcl_wordchars$tcl_nonwordchars|$tcl_nonwordchars$tcl_wordchars)\" [string range $str 0 $start] result]} {\n"
1971 "return [lindex $result 1]\n"
1972 "}\n"
1973 "return -1\n"
1974 "}\n"
1975 "proc tcl_endOfWord {str start} {\n"
1976 "global tcl_nonwordchars tcl_wordchars\n"
1977 "if {[regexp -indices \"$tcl_nonwordchars*$tcl_wordchars+$tcl_nonwordchars\" \\\n"
1978 "\011 [string range $str $start end] result]} {\n"
1979 "return [expr {[lindex $result 1] + $start}]\n"
1980 "}\n"
1981 "return -1\n"
1982 "}\n"
1983 "proc tcl_startOfNextWord {str start} {\n"
1984 "global tcl_nonwordchars tcl_wordchars\n"
1985 "if {[regexp -indices \"$tcl_wordchars*$tcl_nonwordchars+$tcl_wordchars\" \\\n"
1986 "\011 [string range $str $start end] result]} {\n"
1987 "return [expr {[lindex $result 1] + $start}]\n"
1988 "}\n"
1989 "return -1\n"
1990 "}\n"
1991 "proc tcl_startOfPreviousWord {str start} {\n"
1992 "global tcl_nonwordchars tcl_wordchars\n"
1993 "if {[string equal $start end]} {\n"
1994 "set start [string length $str]\n"
1995 "}\n"
1996 "if {[regexp -indices \\\n"
1997 "\011 \"$tcl_nonwordchars*($tcl_wordchars+)$tcl_nonwordchars*\\$\" \\\n"
1998 "\011 [string range $str 0 [expr {$start - 1}]] result word]} {\n"
1999 "return [lindex $word 0]\n"
2000 "}\n"
2001 "return -1\n"
2002 "}\n"
2003 ;
2004 static char Et_zFile8[] =
2005 "proc bgerror err {\n"
2006 "global errorInfo tcl_platform\n"
2007 "set info $errorInfo ;\n"
2008 "set ret [catch {tkerror $err} msg];\n"
2009 "if {$ret != 1} {return -code $ret $msg}\n"
2010 "if {$tcl_platform(platform) == \"macintosh\"} {\n"
2011 "set ok Ok\n"
2012 "} else {\n"
2013 "set ok OK\n"
2014 "}\n"
2015 "set button [tk_dialog .bgerrorDialog \"Error in Tcl Script\" \\\n"
2016 "\011 \"Error: $err\" error 0 $ok \"Skip Messages\" \"Stack Trace\"]\n"
2017 "if {$button == 0} {\n"
2018 "return\n"
2019 "} elseif {$button == 1} {\n"
2020 "return -code break\n"
2021 "}\n"
2022 "set w .bgerrorTrace\n"
2023 "catch {destroy $w}\n"
2024 "toplevel $w -class ErrorTrace\n"
2025 "wm minsize $w 1 1\n"
2026 "wm title $w \"Stack Trace for Error\"\n"
2027 "wm iconname $w \"Stack Trace\"\n"
2028 "button $w.ok -text OK -command \"destroy $w\" -default active\n"
2029 "if {![string compare $tcl_platform(platform) \"macintosh\"]} {\n"
2030 "text $w.text -relief flat -bd 2 -highlightthickness 0 -setgrid true \\\n"
2031 "\011 -yscrollcommand \"$w.scroll set\" -width 60 -height 20\n"
2032 "} else {\n"
2033 "text $w.text -relief sunken -bd 2 -yscrollcommand \"$w.scroll set\" \\\n"
2034 "\011 -setgrid true -width 60 -height 20\n"
2035 "}\n"
2036 "scrollbar $w.scroll -relief sunken -command \"$w.text yview\"\n"
2037 "pack $w.ok -side bottom -padx 3m -pady 2m\n"
2038 "pack $w.scroll -side right -fill y\n"
2039 "pack $w.text -side left -expand yes -fill both\n"
2040 "$w.text insert 0.0 $info\n"
2041 "$w.text mark set insert 0.0\n"
2042 "bind $w <Return> \"destroy $w\"\n"
2043 "bind $w.text <Return> \"destroy $w; break\"\n"
2044 "wm withdraw $w\n"
2045 "update idletasks\n"
2046 "set x [expr {[winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \\\n"
2047 "\011 - [winfo vrootx [winfo parent $w]]}]\n"
2048 "set y [expr {[winfo screenheight $w]/2 - [winfo reqheight $w]/2 \\\n"
2049 "\011 - [winfo vrooty [winfo parent $w]]}]\n"
2050 "wm geom $w +$x+$y\n"
2051 "wm deiconify $w\n"
2052 "if {[string compare [grab current .] \"\"]} {\n"
2053 "grab release [grab current .]\n"
2054 "}\n"
2055 "}\n"
2056 ;
2057 static char Et_zFile9[] =
2058 "if {[string match \"macintosh\" $tcl_platform(platform)]} {\n"
2059 "bind Radiobutton <Enter> {\n"
2060 "tkButtonEnter %W\n"
2061 "}\n"
2062 "bind Radiobutton <1> {\n"
2063 "tkButtonDown %W\n"
2064 "}\n"
2065 "bind Radiobutton <ButtonRelease-1> {\n"
2066 "tkButtonUp %W\n"
2067 "}\n"
2068 "bind Checkbutton <Enter> {\n"
2069 "tkButtonEnter %W\n"
2070 "}\n"
2071 "bind Checkbutton <1> {\n"
2072 "tkButtonDown %W\n"
2073 "}\n"
2074 "bind Checkbutton <ButtonRelease-1> {\n"
2075 "tkButtonUp %W\n"
2076 "}\n"
2077 "}\n"
2078 "if {[string match \"windows\" $tcl_platform(platform)]} {\n"
2079 "bind Checkbutton <equal> {\n"
2080 "tkCheckRadioInvoke %W select\n"
2081 "}\n"
2082 "bind Checkbutton <plus> {\n"
2083 "tkCheckRadioInvoke %W select\n"
2084 "}\n"
2085 "bind Checkbutton <minus> {\n"
2086 "tkCheckRadioInvoke %W deselect\n"
2087 "}\n"
2088 "bind Checkbutton <1> {\n"
2089 "tkCheckRadioDown %W\n"
2090 "}\n"
2091 "bind Checkbutton <ButtonRelease-1> {\n"
2092 "tkButtonUp %W\n"
2093 "}\n"
2094 "bind Checkbutton <Enter> {\n"
2095 "tkCheckRadioEnter %W\n"
2096 "}\n"
2097 "bind Radiobutton <1> {\n"
2098 "tkCheckRadioDown %W\n"
2099 "}\n"
2100 "bind Radiobutton <ButtonRelease-1> {\n"
2101 "tkButtonUp %W\n"
2102 "}\n"
2103 "bind Radiobutton <Enter> {\n"
2104 "tkCheckRadioEnter %W\n"
2105 "}\n"
2106 "}\n"
2107 "if {[string match \"unix\" $tcl_platform(platform)]} {\n"
2108 "bind Checkbutton <Return> {\n"
2109 "if {!$tk_strictMotif} {\n"
2110 "tkCheckRadioInvoke %W\n"
2111 "}\n"
2112 "}\n"
2113 "bind Radiobutton <Return> {\n"
2114 "if {!$tk_strictMotif} {\n"
2115 "tkCheckRadioInvoke %W\n"
2116 "}\n"
2117 "}\n"
2118 "bind Checkbutton <1> {\n"
2119 "tkCheckRadioInvoke %W\n"
2120 "}\n"
2121 "bind Radiobutton <1> {\n"
2122 "tkCheckRadioInvoke %W\n"
2123 "}\n"
2124 "bind Checkbutton <Enter> {\n"
2125 "tkButtonEnter %W\n"
2126 "}\n"
2127 "bind Radiobutton <Enter> {\n"
2128 "tkButtonEnter %W\n"
2129 "}\n"
2130 "}\n"
2131 "bind Button <space> {\n"
2132 "tkButtonInvoke %W\n"
2133 "}\n"
2134 "bind Checkbutton <space> {\n"
2135 "tkCheckRadioInvoke %W\n"
2136 "}\n"
2137 "bind Radiobutton <space> {\n"
2138 "tkCheckRadioInvoke %W\n"
2139 "}\n"
2140 "bind Button <FocusIn> {}\n"
2141 "bind Button <Enter> {\n"
2142 "tkButtonEnter %W\n"
2143 "}\n"
2144 "bind Button <Leave> {\n"
2145 "tkButtonLeave %W\n"
2146 "}\n"
2147 "bind Button <1> {\n"
2148 "tkButtonDown %W\n"
2149 "}\n"
2150 "bind Button <ButtonRelease-1> {\n"
2151 "tkButtonUp %W\n"
2152 "}\n"
2153 "bind Checkbutton <FocusIn> {}\n"
2154 "bind Checkbutton <Leave> {\n"
2155 "tkButtonLeave %W\n"
2156 "}\n"
2157 "bind Radiobutton <FocusIn> {}\n"
2158 "bind Radiobutton <Leave> {\n"
2159 "tkButtonLeave %W\n"
2160 "}\n"
2161 "if {[string match \"windows\" $tcl_platform(platform)]} {\n"
2162 "proc tkButtonEnter w {\n"
2163 "global tkPriv\n"
2164 "if {[string compare [$w cget -state] \"disabled\"] \\\n"
2165 "\011 && [string equal $tkPriv(buttonWindow) $w]} {\n"
2166 "$w configure -state active -relief sunken\n"
2167 "}\n"
2168 "set tkPriv(window) $w\n"
2169 "}\n"
2170 "proc tkButtonLeave w {\n"
2171 "global tkPriv\n"
2172 "if {[string compare [$w cget -state] \"disabled\"]} {\n"
2173 "$w configure -state normal\n"
2174 "}\n"
2175 "if {[string equal $tkPriv(buttonWindow) $w]} {\n"
2176 "$w configure -relief $tkPriv(relief)\n"
2177 "}\n"
2178 "set tkPriv(window) \"\"\n"
2179 "}\n"
2180 "proc tkCheckRadioEnter w {\n"
2181 "global tkPriv\n"
2182 "if {[string compare [$w cget -state] \"disabled\"] \\\n"
2183 "\011 && [string equal $tkPriv(buttonWindow) $w]} {\n"
2184 "$w configure -state active\n"
2185 "}\n"
2186 "set tkPriv(window) $w\n"
2187 "}\n"
2188 "proc tkButtonDown w {\n"
2189 "global tkPriv\n"
2190 "set tkPriv(relief) [$w cget -relief]\n"
2191 "if {[string compare [$w cget -state] \"disabled\"]} {\n"
2192 "set tkPriv(buttonWindow) $w\n"
2193 "$w configure -relief sunken -state active\n"
2194 "}\n"
2195 "}\n"
2196 "proc tkCheckRadioDown w {\n"
2197 "global tkPriv\n"
2198 "set tkPriv(relief) [$w cget -relief]\n"
2199 "if {[string compare [$w cget -state] \"disabled\"]} {\n"
2200 "set tkPriv(buttonWindow) $w\n"
2201 "$w configure -state active\n"
2202 "}\n"
2203 "}\n"
2204 "proc tkButtonUp w {\n"
2205 "global tkPriv\n"
2206 "if {[string equal $tkPriv(buttonWindow) $w]} {\n"
2207 "set tkPriv(buttonWindow) \"\"\n"
2208 "$w configure -relief $tkPriv(relief)\n"
2209 "if {[string equal $tkPriv(window) $w]\n"
2210 "&& [string compare [$w cget -state] \"disabled\"]} {\n"
2211 "$w configure -state normal\n"
2212 "uplevel #0 [list $w invoke]\n"
2213 "}\n"
2214 "}\n"
2215 "}\n"
2216 "}\n"
2217 "if {[string match \"unix\" $tcl_platform(platform)]} {\n"
2218 "proc tkButtonEnter {w} {\n"
2219 "global tkPriv\n"
2220 "if {[string compare [$w cget -state] \"disabled\"]} {\n"
2221 "$w configure -state active\n"
2222 "if {[string equal $tkPriv(buttonWindow) $w]} {\n"
2223 "$w configure -state active -relief sunken\n"
2224 "}\n"
2225 "}\n"
2226 "set tkPriv(window) $w\n"
2227 "}\n"
2228 "proc tkButtonLeave w {\n"
2229 "global tkPriv\n"
2230 "if {[string compare [$w cget -state] \"disabled\"]} {\n"
2231 "$w configure -state normal\n"
2232 "}\n"
2233 "if {[string equal $tkPriv(buttonWindow) $w]} {\n"
2234 "$w configure -relief $tkPriv(relief)\n"
2235 "}\n"
2236 "set tkPriv(window) \"\"\n"
2237 "}\n"
2238 "proc tkButtonDown w {\n"
2239 "global tkPriv\n"
2240 "set tkPriv(relief) [$w cget -relief]\n"
2241 "if {[string compare [$w cget -state] \"disabled\"]} {\n"
2242 "set tkPriv(buttonWindow) $w\n"
2243 "$w configure -relief sunken\n"
2244 "}\n"
2245 "}\n"
2246 "proc tkButtonUp w {\n"
2247 "global tkPriv\n"
2248 "if {[string equal $w $tkPriv(buttonWindow)]} {\n"
2249 "set tkPriv(buttonWindow) \"\"\n"
2250 "$w configure -relief $tkPriv(relief)\n"
2251 "if {[string equal $w $tkPriv(window)] \\\n"
2252 "\011\011&& [string compare [$w cget -state] \"disabled\"]} {\n"
2253 "uplevel #0 [list $w invoke]\n"
2254 "}\n"
2255 "}\n"
2256 "}\n"
2257 "}\n"
2258 "if {[string match \"macintosh\" $tcl_platform(platform)]} {\n"
2259 "proc tkButtonEnter {w} {\n"
2260 "global tkPriv\n"
2261 "if {[string compare [$w cget -state] \"disabled\"]} {\n"
2262 "if {[string equal $w $tkPriv(buttonWindow)]} {\n"
2263 "$w configure -state active\n"
2264 "}\n"
2265 "}\n"
2266 "set tkPriv(window) $w\n"
2267 "}\n"
2268 "proc tkButtonLeave w {\n"
2269 "global tkPriv\n"
2270 "if {[string equal $w $tkPriv(buttonWindow)]} {\n"
2271 "$w configure -state normal\n"
2272 "}\n"
2273 "set tkPriv(window) \"\"\n"
2274 "}\n"
2275 "proc tkButtonDown w {\n"
2276 "global tkPriv\n"
2277 "if {[string compare [$w cget -state] \"disabled\"]} {\n"
2278 "set tkPriv(buttonWindow) $w\n"
2279 "$w configure -state active\n"
2280 "}\n"
2281 "}\n"
2282 "proc tkButtonUp w {\n"
2283 "global tkPriv\n"
2284 "if {[string equal $w $tkPriv(buttonWindow)]} {\n"
2285 "$w configure -state normal\n"
2286 "set tkPriv(buttonWindow) \"\"\n"
2287 "if {[string equal $w $tkPriv(window)]\n"
2288 "&& [string compare [$w cget -state] \"disabled\"]} {\n"
2289 "uplevel #0 [list $w invoke]\n"
2290 "}\n"
2291 "}\n"
2292 "}\n"
2293 "}\n"
2294 "proc tkButtonInvoke w {\n"
2295 "if {[string compare [$w cget -state] \"disabled\"]} {\n"
2296 "set oldRelief [$w cget -relief]\n"
2297 "set oldState [$w cget -state]\n"
2298 "$w configure -state active -relief sunken\n"
2299 "update idletasks\n"
2300 "after 100\n"
2301 "$w configure -state $oldState -relief $oldRelief\n"
2302 "uplevel #0 [list $w invoke]\n"
2303 "}\n"
2304 "}\n"
2305 "proc tkCheckRadioInvoke {w {cmd invoke}} {\n"
2306 "if {[string compare [$w cget -state] \"disabled\"]} {\n"
2307 "uplevel #0 [list $w $cmd]\n"
2308 "}\n"
2309 "}\n"
2310 ;
2311 static char Et_zFile10[] =
2312 "proc tkColorDialog {args} {\n"
2313 "global tkPriv\n"
2314 "set w .__tk__color\n"
2315 "upvar #0 $w data\n"
2316 "set data(lines,red,start) 0\n"
2317 "set data(lines,red,last) -1\n"
2318 "set data(lines,green,start) 0\n"
2319 "set data(lines,green,last) -1\n"
2320 "set data(lines,blue,start) 0\n"
2321 "set data(lines,blue,last) -1\n"
2322 "set data(NUM_COLORBARS) 8\n"
2323 "set data(BARS_WIDTH) 128\n"
2324 "set data(PLGN_HEIGHT) 10\n"
2325 "set data(PLGN_WIDTH) 10\n"
2326 "tkColorDialog_Config $w $args\n"
2327 "tkColorDialog_InitValues $w\n"
2328 "set sc [winfo screen $data(-parent)]\n"
2329 "set winExists [winfo exists $w]\n"
2330 "if {!$winExists || [string compare $sc [winfo screen $w]]} {\n"
2331 "if {$winExists} {\n"
2332 "destroy $w\n"
2333 "}\n"
2334 "toplevel $w -class tkColorDialog -screen $sc\n"
2335 "tkColorDialog_BuildDialog $w\n"
2336 "}\n"
2337 "wm transient $w $data(-parent)\n"
2338 "::tk::PlaceWindow $w widget $data(-parent)\n"
2339 "wm title $w $data(-title)\n"
2340 "::tk::SetFocusGrab $w $data(okBtn)\n"
2341 "vwait tkPriv(selectColor)\n"
2342 "::tk::RestoreFocusGrab $w $data(okBtn)\n"
2343 "unset data\n"
2344 "return $tkPriv(selectColor)\n"
2345 "}\n"
2346 "proc tkColorDialog_InitValues {w} {\n"
2347 "upvar #0 $w data\n"
2348 "set data(intensityIncr) [expr {256 / $data(NUM_COLORBARS)}]\n"
2349 "set data(colorbarWidth) \\\n"
2350 "\011 [expr {$data(BARS_WIDTH) / $data(NUM_COLORBARS)}]\n"
2351 "set data(indent) [expr {$data(PLGN_WIDTH) / 2}]\n"
2352 "set data(colorPad) 2\n"
2353 "set data(selPad) [expr {$data(PLGN_WIDTH) / 2}]\n"
2354 "set data(minX) $data(indent)\n"
2355 "set data(maxX) [expr {$data(BARS_WIDTH) + $data(indent)-1}]\n"
2356 "set data(canvasWidth) [expr {$data(BARS_WIDTH) + $data(PLGN_WIDTH)}]\n"
2357 "set data(selection) $data(-initialcolor)\n"
2358 "set data(finalColor) $data(-initialcolor)\n"
2359 "set rgb [winfo rgb . $data(selection)]\n"
2360 "set data(red,intensity) [expr {[lindex $rgb 0]/0x100}]\n"
2361 "set data(green,intensity) [expr {[lindex $rgb 1]/0x100}]\n"
2362 "set data(blue,intensity) [expr {[lindex $rgb 2]/0x100}]\n"
2363 "}\n"
2364 "proc tkColorDialog_Config {w argList} {\n"
2365 "global tkPriv\n"
2366 "upvar #0 $w data\n"
2367 "if {[info exists tkPriv(selectColor)] && \\\n"
2368 "\011 [string compare $tkPriv(selectColor) \"\"]} {\n"
2369 "set defaultColor $tkPriv(selectColor)\n"
2370 "} else {\n"
2371 "set defaultColor [. cget -background]\n"
2372 "}\n"
2373 "set specs [list \\\n"
2374 "\011 [list -initialcolor \"\" \"\" $defaultColor] \\\n"
2375 "\011 [list -parent \"\" \"\" \".\"] \\\n"
2376 "\011 [list -title \"\" \"\" \"Color\"] \\\n"
2377 "\011 ]\n"
2378 "tclParseConfigSpec $w $specs \"\" $argList\n"
2379 "if {[string equal $data(-title) \"\"]} {\n"
2380 "set data(-title) \" \"\n"
2381 "}\n"
2382 "if {[catch {winfo rgb . $data(-initialcolor)} err]} {\n"
2383 "error $err\n"
2384 "}\n"
2385 "if {![winfo exists $data(-parent)]} {\n"
2386 "error \"bad window path name \\\"$data(-parent)\\\"\"\n"
2387 "}\n"
2388 "}\n"
2389 "proc tkColorDialog_BuildDialog {w} {\n"
2390 "upvar #0 $w data\n"
2391 "set topFrame [frame $w.top -relief raised -bd 1]\n"
2392 "set stripsFrame [frame $topFrame.colorStrip]\n"
2393 "foreach c { Red Green Blue } {\n"
2394 "set color [string tolower $c]\n"
2395 "set f [frame $stripsFrame.$color]\n"
2396 "set box [frame $f.box]\n"
2397 "label $box.label -text $c: -width 6 -under 0 -anchor ne\n"
2398 "entry $box.entry -textvariable [format %s $w]($color,intensity) \\\n"
2399 "\011 -width 4\n"
2400 "pack $box.label -side left -fill y -padx 2 -pady 3\n"
2401 "pack $box.entry -side left -anchor n -pady 0\n"
2402 "pack $box -side left -fill both\n"
2403 "set height [expr \\\n"
2404 "\011 {[winfo reqheight $box.entry] - \\\n"
2405 "\011 2*([$box.entry cget -highlightthickness] + [$box.entry cget -bd])}]\n"
2406 "canvas $f.color -height $height\\\n"
2407 "\011 -width $data(BARS_WIDTH) -relief sunken -bd 2\n"
2408 "canvas $f.sel -height $data(PLGN_HEIGHT) \\\n"
2409 "\011 -width $data(canvasWidth) -highlightthickness 0\n"
2410 "pack $f.color -expand yes -fill both\n"
2411 "pack $f.sel -expand yes -fill both\n"
2412 "pack $f -side top -fill x -padx 0 -pady 2\n"
2413 "set data($color,entry) $box.entry\n"
2414 "set data($color,col) $f.color\n"
2415 "set data($color,sel) $f.sel\n"
2416 "bind $data($color,col) <Configure> \\\n"
2417 "\011 [list tkColorDialog_DrawColorScale $w $color 1]\n"
2418 "bind $data($color,col) <Enter> \\\n"
2419 "\011 [list tkColorDialog_EnterColorBar $w $color]\n"
2420 "bind $data($color,col) <Leave> \\\n"
2421 "\011 [list tkColorDialog_LeaveColorBar $w $color]\n"
2422 "bind $data($color,sel) <Enter> \\\n"
2423 "\011 [list tkColorDialog_EnterColorBar $w $color]\n"
2424 "bind $data($color,sel) <Leave> \\\n"
2425 "\011 [list tkColorDialog_LeaveColorBar $w $color]\n"
2426 "bind $box.entry <Return> [list tkColorDialog_HandleRGBEntry $w]\n"
2427 "}\n"
2428 "pack $stripsFrame -side left -fill both -padx 4 -pady 10\n"
2429 "set selFrame [frame $topFrame.sel]\n"
2430 "set lab [label $selFrame.lab -text \"Selection:\" -under 0 -anchor sw]\n"
2431 "set ent [entry $selFrame.ent -textvariable [format %s $w](selection) \\\n"
2432 "\011-width 16]\n"
2433 "set f1 [frame $selFrame.f1 -relief sunken -bd 2]\n"
2434 "set data(finalCanvas) [frame $f1.demo -bd 0 -width 100 -height 70]\n"
2435 "pack $lab $ent -side top -fill x -padx 4 -pady 2\n"
2436 "pack $f1 -expand yes -anchor nw -fill both -padx 6 -pady 10\n"
2437 "pack $data(finalCanvas) -expand yes -fill both\n"
2438 "bind $ent <Return> [list tkColorDialog_HandleSelEntry $w]\n"
2439 "pack $selFrame -side left -fill none -anchor nw\n"
2440 "pack $topFrame -side top -expand yes -fill both -anchor nw\n"
2441 "set botFrame [frame $w.bot -relief raised -bd 1]\n"
2442 "button $botFrame.ok -text OK -width 8 -under 0 \\\n"
2443 "\011-command [list tkColorDialog_OkCmd $w]\n"
2444 "button $botFrame.cancel -text Cancel -width 8 -under 0 \\\n"
2445 "\011-command [list tkColorDialog_CancelCmd $w]\n"
2446 "set data(okBtn) $botFrame.ok\n"
2447 "set data(cancelBtn) $botFrame.cancel\n"
2448 "pack $botFrame.ok $botFrame.cancel \\\n"
2449 "\011-padx 10 -pady 10 -expand yes -side left\n"
2450 "pack $botFrame -side bottom -fill x\n"
2451 "bind $w <Alt-r> [list focus $data(red,entry)]\n"
2452 "bind $w <Alt-g> [list focus $data(green,entry)]\n"
2453 "bind $w <Alt-b> [list focus $data(blue,entry)]\n"
2454 "bind $w <Alt-s> [list focus $ent]\n"
2455 "bind $w <KeyPress-Escape> [list tkButtonInvoke $data(cancelBtn)]\n"
2456 "bind $w <Alt-c> [list tkButtonInvoke $data(cancelBtn)]\n"
2457 "bind $w <Alt-o> [list tkButtonInvoke $data(okBtn)]\n"
2458 "wm protocol $w WM_DELETE_WINDOW [list tkColorDialog_CancelCmd $w]\n"
2459 "}\n"
2460 "proc tkColorDialog_SetRGBValue {w color} {\n"
2461 "upvar #0 $w data \n"
2462 "set data(red,intensity) [lindex $color 0]\n"
2463 "set data(green,intensity) [lindex $color 1]\n"
2464 "set data(blue,intensity) [lindex $color 2]\n"
2465 "tkColorDialog_RedrawColorBars $w all\n"
2466 "foreach color { red green blue } {\n"
2467 "set x [tkColorDialog_RgbToX $w $data($color,intensity)]\n"
2468 "tkColorDialog_MoveSelector $w $data($color,sel) $color $x 0\n"
2469 "}\n"
2470 "}\n"
2471 "proc tkColorDialog_XToRgb {w x} {\n"
2472 "upvar #0 $w data\n"
2473 "return [expr {($x * $data(intensityIncr))/ $data(colorbarWidth)}]\n"
2474 "}\n"
2475 "proc tkColorDialog_RgbToX {w color} {\n"
2476 "upvar #0 $w data\n"
2477 "return [expr {($color * $data(colorbarWidth)/ $data(intensityIncr))}]\n"
2478 "}\n"
2479 "proc tkColorDialog_DrawColorScale {w c {create 0}} {\n"
2480 "global lines\n"
2481 "upvar #0 $w data\n"
2482 "set col $data($c,col)\n"
2483 "set sel $data($c,sel)\n"
2484 "if {$create} {\n"
2485 "if { $data(lines,$c,last) > $data(lines,$c,start)} {\n"
2486 "for {set i $data(lines,$c,start)} \\\n"
2487 "\011\011{$i <= $data(lines,$c,last)} { incr i} {\n"
2488 "$sel delete $i\n"
2489 "}\n"
2490 "}\n"
2491 "if {[info exists data($c,index)]} {\n"
2492 "$sel delete $data($c,index)\n"
2493 "}\n"
2494 "tkColorDialog_CreateSelector $w $sel $c\n"
2495 "$sel bind $data($c,index) <ButtonPress-1> \\\n"
2496 "\011\011[list tkColorDialog_StartMove $w $sel $c %x $data(selPad) 1]\n"
2497 "$sel bind $data($c,index) <B1-Motion> \\\n"
2498 "\011\011[list tkColorDialog_MoveSelector $w $sel $c %x $data(selPad)]\n"
2499 "$sel bind $data($c,index) <ButtonRelease-1> \\\n"
2500 "\011\011[list tkColorDialog_ReleaseMouse $w $sel $c %x $data(selPad)]\n"
2501 "set height [winfo height $col]\n"
2502 "set data($c,clickRegion) [$sel create rectangle 0 0 \\\n"
2503 "\011\011$data(canvasWidth) $height -fill {} -outline {}]\n"
2504 "bind $col <ButtonPress-1> \\\n"
2505 "\011\011[list tkColorDialog_StartMove $w $sel $c %x $data(colorPad)]\n"
2506 "bind $col <B1-Motion> \\\n"
2507 "\011\011[list tkColorDialog_MoveSelector $w $sel $c %x $data(colorPad)]\n"
2508 "bind $col <ButtonRelease-1> \\\n"
2509 "\011\011[list tkColorDialog_ReleaseMouse $w $sel $c %x $data(colorPad)]\n"
2510 "$sel bind $data($c,clickRegion) <ButtonPress-1> \\\n"
2511 "\011\011[list tkColorDialog_StartMove $w $sel $c %x $data(selPad)]\n"
2512 "$sel bind $data($c,clickRegion) <B1-Motion> \\\n"
2513 "\011\011[list tkColorDialog_MoveSelector $w $sel $c %x $data(selPad)]\n"
2514 "$sel bind $data($c,clickRegion) <ButtonRelease-1> \\\n"
2515 "\011\011[list tkColorDialog_ReleaseMouse $w $sel $c %x $data(selPad)]\n"
2516 "} else {\n"
2517 "set l $data(lines,$c,start)\n"
2518 "}\n"
2519 "set highlightW [expr {[$col cget -highlightthickness] + [$col cget -bd]}]\n"
2520 "for {set i 0} { $i < $data(NUM_COLORBARS)} { incr i} {\n"
2521 "set intensity [expr {$i * $data(intensityIncr)}]\n"
2522 "set startx [expr {$i * $data(colorbarWidth) + $highlightW}]\n"
2523 "if {[string equal $c \"red\"]} {\n"
2524 "set color [format \"#%02x%02x%02x\" \\\n"
2525 "\011\011\011 $intensity \\\n"
2526 "\011\011\011 $data(green,intensity) \\\n"
2527 "\011\011\011 $data(blue,intensity)]\n"
2528 "} elseif {[string equal $c \"green\"]} {\n"
2529 "set color [format \"#%02x%02x%02x\" \\\n"
2530 "\011\011\011 $data(red,intensity) \\\n"
2531 "\011\011\011 $intensity \\\n"
2532 "\011\011\011 $data(blue,intensity)]\n"
2533 "} else {\n"
2534 "set color [format \"#%02x%02x%02x\" \\\n"
2535 "\011\011\011 $data(red,intensity) \\\n"
2536 "\011\011\011 $data(green,intensity) \\\n"
2537 "\011\011\011 $intensity]\n"
2538 "}\n"
2539 "if {$create} {\n"
2540 "set index [$col create rect $startx $highlightW \\\n"
2541 "\011\011 [expr {$startx +$data(colorbarWidth)}] \\\n"
2542 "\011\011 [expr {[winfo height $col] + $highlightW}]\\\n"
2543 "\011 -fill $color -outline $color]\n"
2544 "} else {\n"
2545 "$col itemconfigure $l -fill $color -outline $color\n"
2546 "incr l\n"
2547 "}\n"
2548 "}\n"
2549 "$sel raise $data($c,index)\n"
2550 "if {$create} {\n"
2551 "set data(lines,$c,last) $index\n"
2552 "set data(lines,$c,start) [expr {$index - $data(NUM_COLORBARS) + 1}]\n"
2553 "}\n"
2554 "tkColorDialog_RedrawFinalColor $w\n"
2555 "}\n"
2556 "proc tkColorDialog_CreateSelector {w sel c } {\n"
2557 "upvar #0 $w data\n"
2558 "set data($c,index) [$sel create polygon \\\n"
2559 "\0110 $data(PLGN_HEIGHT) \\\n"
2560 "\011$data(PLGN_WIDTH) $data(PLGN_HEIGHT) \\\n"
2561 "\011$data(indent) 0]\n"
2562 "set data($c,x) [tkColorDialog_RgbToX $w $data($c,intensity)]\n"
2563 "$sel move $data($c,index) $data($c,x) 0\n"
2564 "}\n"
2565 "proc tkColorDialog_RedrawFinalColor {w} {\n"
2566 "upvar #0 $w data\n"
2567 "set color [format \"#%02x%02x%02x\" $data(red,intensity) \\\n"
2568 "\011$data(green,intensity) $data(blue,intensity)]\n"
2569 "$data(finalCanvas) configure -bg $color\n"
2570 "set data(finalColor) $color\n"
2571 "set data(selection) $color\n"
2572 "set data(finalRGB) [list \\\n"
2573 "\011 $data(red,intensity) \\\n"
2574 "\011 $data(green,intensity) \\\n"
2575 "\011 $data(blue,intensity)]\n"
2576 "}\n"
2577 "proc tkColorDialog_RedrawColorBars {w colorChanged} {\n"
2578 "upvar #0 $w data\n"
2579 "switch $colorChanged {\n"
2580 "red { \n"
2581 "tkColorDialog_DrawColorScale $w green\n"
2582 "tkColorDialog_DrawColorScale $w blue\n"
2583 "}\n"
2584 "green {\n"
2585 "tkColorDialog_DrawColorScale $w red\n"
2586 "tkColorDialog_DrawColorScale $w blue\n"
2587 "}\n"
2588 "blue {\n"
2589 "tkColorDialog_DrawColorScale $w red\n"
2590 "tkColorDialog_DrawColorScale $w green\n"
2591 "}\n"
2592 "default {\n"
2593 "tkColorDialog_DrawColorScale $w red\n"
2594 "tkColorDialog_DrawColorScale $w green\n"
2595 "tkColorDialog_DrawColorScale $w blue\n"
2596 "}\n"
2597 "}\n"
2598 "tkColorDialog_RedrawFinalColor $w\n"
2599 "}\n"
2600 "proc tkColorDialog_StartMove {w sel color x delta {dontMove 0}} {\n"
2601 "upvar #0 $w data\n"
2602 "if {!$dontMove} {\n"
2603 "tkColorDialog_MoveSelector $w $sel $color $x $delta\n"
2604 "}\n"
2605 "}\n"
2606 "proc tkColorDialog_MoveSelector {w sel color x delta} {\n"
2607 "upvar #0 $w data\n"
2608 "incr x -$delta\n"
2609 "if { $x < 0 } {\n"
2610 "set x 0\n"
2611 "} elseif { $x >= $data(BARS_WIDTH)} {\n"
2612 "set x [expr {$data(BARS_WIDTH) - 1}]\n"
2613 "}\n"
2614 "set diff [expr {$x - $data($color,x)}]\n"
2615 "$sel move $data($color,index) $diff 0\n"
2616 "set data($color,x) [expr {$data($color,x) + $diff}]\n"
2617 "return $x\n"
2618 "}\n"
2619 "proc tkColorDialog_ReleaseMouse {w sel color x delta} {\n"
2620 "upvar #0 $w data \n"
2621 "set x [tkColorDialog_MoveSelector $w $sel $color $x $delta]\n"
2622 "set data($color,intensity) [tkColorDialog_XToRgb $w $x]\n"
2623 "tkColorDialog_RedrawColorBars $w $color\n"
2624 "}\n"
2625 "proc tkColorDialog_ResizeColorBars {w} {\n"
2626 "upvar #0 $w data\n"
2627 "if { ($data(BARS_WIDTH) < $data(NUM_COLORBARS)) || \n"
2628 "(($data(BARS_WIDTH) % $data(NUM_COLORBARS)) != 0)} {\n"
2629 "set data(BARS_WIDTH) $data(NUM_COLORBARS)\n"
2630 "}\n"
2631 "tkColorDialog_InitValues $w\n"
2632 "foreach color { red green blue } {\n"
2633 "$data($color,col) configure -width $data(canvasWidth)\n"
2634 "tkColorDialog_DrawColorScale $w $color 1\n"
2635 "}\n"
2636 "}\n"
2637 "proc tkColorDialog_HandleSelEntry {w} {\n"
2638 "upvar #0 $w data\n"
2639 "set text [string trim $data(selection)]\n"
2640 "if {[catch {set color [winfo rgb . $text]} ]} {\n"
2641 "set data(selection) $data(finalColor)\n"
2642 "return\n"
2643 "}\n"
2644 "set R [expr {[lindex $color 0]/0x100}]\n"
2645 "set G [expr {[lindex $color 1]/0x100}]\n"
2646 "set B [expr {[lindex $color 2]/0x100}]\n"
2647 "tkColorDialog_SetRGBValue $w \"$R $G $B\"\n"
2648 "set data(selection) $text\n"
2649 "}\n"
2650 "proc tkColorDialog_HandleRGBEntry {w} {\n"
2651 "upvar #0 $w data\n"
2652 "foreach c {red green blue} {\n"
2653 "if {[catch {\n"
2654 "set data($c,intensity) [expr {int($data($c,intensity))}]\n"
2655 "}]} {\n"
2656 "set data($c,intensity) 0\n"
2657 "}\n"
2658 "if {$data($c,intensity) < 0} {\n"
2659 "set data($c,intensity) 0\n"
2660 "}\n"
2661 "if {$data($c,intensity) > 255} {\n"
2662 "set data($c,intensity) 255\n"
2663 "}\n"
2664 "}\n"
2665 "tkColorDialog_SetRGBValue $w \"$data(red,intensity) $data(green,intensity) \\\n"
2666 "\011$data(blue,intensity)\"\n"
2667 "} \n"
2668 "proc tkColorDialog_EnterColorBar {w color} {\n"
2669 "upvar #0 $w data\n"
2670 "$data($color,sel) itemconfig $data($color,index) -fill red\n"
2671 "}\n"
2672 "proc tkColorDialog_LeaveColorBar {w color} {\n"
2673 "upvar #0 $w data\n"
2674 "$data($color,sel) itemconfig $data($color,index) -fill black\n"
2675 "}\n"
2676 "proc tkColorDialog_OkCmd {w} {\n"
2677 "global tkPriv\n"
2678 "upvar #0 $w data\n"
2679 "set tkPriv(selectColor) $data(finalColor)\n"
2680 "}\n"
2681 "proc tkColorDialog_CancelCmd {w} {\n"
2682 "global tkPriv\n"
2683 "set tkPriv(selectColor) \"\"\n"
2684 "}\n"
2685 ;
2686 static char Et_zFile11[] =
2687 "proc tclParseConfigSpec {w specs flags argList} {\n"
2688 "upvar #0 $w data\n"
2689 "foreach spec $specs {\n"
2690 "if {[llength $spec] < 4} {\n"
2691 "error \"\\\"spec\\\" should contain 5 or 4 elements\"\n"
2692 "}\n"
2693 "set cmdsw [lindex $spec 0]\n"
2694 "set cmd($cmdsw) \"\"\n"
2695 "set rname($cmdsw) [lindex $spec 1]\n"
2696 "set rclass($cmdsw) [lindex $spec 2]\n"
2697 "set def($cmdsw) [lindex $spec 3]\n"
2698 "set verproc($cmdsw) [lindex $spec 4]\n"
2699 "}\n"
2700 "if {[llength $argList] & 1} {\n"
2701 "set cmdsw [lindex $argList end]\n"
2702 "if {![info exists cmd($cmdsw)]} {\n"
2703 "error \"bad option \\\"$cmdsw\\\": must be [tclListValidFlags cmd]\"\n"
2704 "}\n"
2705 "error \"value for \\\"$cmdsw\\\" missing\"\n"
2706 "}\n"
2707 "foreach cmdsw [array names cmd] {\n"
2708 "set data($cmdsw) $def($cmdsw)\n"
2709 "}\n"
2710 "foreach {cmdsw value} $argList {\n"
2711 "if {![info exists cmd($cmdsw)]} {\n"
2712 "error \"bad option \\\"$cmdsw\\\": must be [tclListValidFlags cmd]\"\n"
2713 "}\n"
2714 "set data($cmdsw) $value\n"
2715 "}\n"
2716 "}\n"
2717 "proc tclListValidFlags {v} {\n"
2718 "upvar $v cmd\n"
2719 "set len [llength [array names cmd]]\n"
2720 "set i 1\n"
2721 "set separator \"\"\n"
2722 "set errormsg \"\"\n"
2723 "foreach cmdsw [lsort [array names cmd]] {\n"
2724 "append errormsg \"$separator$cmdsw\"\n"
2725 "incr i\n"
2726 "if {$i == $len} {\n"
2727 "set separator \", or \"\n"
2728 "} else {\n"
2729 "set separator \", \"\n"
2730 "}\n"
2731 "}\n"
2732 "return $errormsg\n"
2733 "}\n"
2734 "proc tkFocusGroup_Create {t} {\n"
2735 "global tkPriv\n"
2736 "if {[string compare [winfo toplevel $t] $t]} {\n"
2737 "error \"$t is not a toplevel window\"\n"
2738 "}\n"
2739 "if {![info exists tkPriv(fg,$t)]} {\n"
2740 "set tkPriv(fg,$t) 1\n"
2741 "set tkPriv(focus,$t) \"\"\n"
2742 "bind $t <FocusIn> [list tkFocusGroup_In $t %W %d]\n"
2743 "bind $t <FocusOut> [list tkFocusGroup_Out $t %W %d]\n"
2744 "bind $t <Destroy> [list tkFocusGroup_Destroy $t %W]\n"
2745 "}\n"
2746 "}\n"
2747 "proc tkFocusGroup_BindIn {t w cmd} {\n"
2748 "global tkFocusIn tkPriv\n"
2749 "if {![info exists tkPriv(fg,$t)]} {\n"
2750 "error \"focus group \\\"$t\\\" doesn't exist\"\n"
2751 "}\n"
2752 "set tkFocusIn($t,$w) $cmd\n"
2753 "}\n"
2754 "proc tkFocusGroup_BindOut {t w cmd} {\n"
2755 "global tkFocusOut tkPriv\n"
2756 "if {![info exists tkPriv(fg,$t)]} {\n"
2757 "error \"focus group \\\"$t\\\" doesn't exist\"\n"
2758 "}\n"
2759 "set tkFocusOut($t,$w) $cmd\n"
2760 "}\n"
2761 "proc tkFocusGroup_Destroy {t w} {\n"
2762 "global tkPriv tkFocusIn tkFocusOut\n"
2763 "if {[string equal $t $w]} {\n"
2764 "unset tkPriv(fg,$t)\n"
2765 "unset tkPriv(focus,$t) \n"
2766 "foreach name [array names tkFocusIn $t,*] {\n"
2767 "unset tkFocusIn($name)\n"
2768 "}\n"
2769 "foreach name [array names tkFocusOut $t,*] {\n"
2770 "unset tkFocusOut($name)\n"
2771 "}\n"
2772 "} else {\n"
2773 "if {[info exists tkPriv(focus,$t)] && \\\n"
2774 "\011\011[string equal $tkPriv(focus,$t) $w]} {\n"
2775 "set tkPriv(focus,$t) \"\"\n"
2776 "}\n"
2777 "catch {\n"
2778 "unset tkFocusIn($t,$w)\n"
2779 "}\n"
2780 "catch {\n"
2781 "unset tkFocusOut($t,$w)\n"
2782 "}\n"
2783 "}\n"
2784 "}\n"
2785 "proc tkFocusGroup_In {t w detail} {\n"
2786 "global tkPriv tkFocusIn\n"
2787 "if {[string compare $detail NotifyNonlinear] && \\\n"
2788 "\011 [string compare $detail NotifyNonlinearVirtual]} {\n"
2789 "return\n"
2790 "}\n"
2791 "if {![info exists tkFocusIn($t,$w)]} {\n"
2792 "set tkFocusIn($t,$w) \"\"\n"
2793 "return\n"
2794 "}\n"
2795 "if {![info exists tkPriv(focus,$t)]} {\n"
2796 "return\n"
2797 "}\n"
2798 "if {[string equal $tkPriv(focus,$t) $w]} {\n"
2799 "return\n"
2800 "} else {\n"
2801 "set tkPriv(focus,$t) $w\n"
2802 "eval $tkFocusIn($t,$w)\n"
2803 "}\n"
2804 "}\n"
2805 "proc tkFocusGroup_Out {t w detail} {\n"
2806 "global tkPriv tkFocusOut\n"
2807 "if {[string compare $detail NotifyNonlinear] && \\\n"
2808 "\011 [string compare $detail NotifyNonlinearVirtual]} {\n"
2809 "return\n"
2810 "}\n"
2811 "if {![info exists tkPriv(focus,$t)]} {\n"
2812 "return\n"
2813 "}\n"
2814 "if {![info exists tkFocusOut($t,$w)]} {\n"
2815 "return\n"
2816 "} else {\n"
2817 "eval $tkFocusOut($t,$w)\n"
2818 "set tkPriv(focus,$t) \"\"\n"
2819 "}\n"
2820 "}\n"
2821 "proc tkFDGetFileTypes {string} {\n"
2822 "foreach t $string {\n"
2823 "if {[llength $t] < 2 || [llength $t] > 3} {\n"
2824 "error \"bad file type \\\"$t\\\", should be \\\"typeName {extension ?extensions ...?} ?{macType ?macTypes ...?}?\\\"\"\n"
2825 "}\n"
2826 "eval lappend [list fileTypes([lindex $t 0])] [lindex $t 1]\n"
2827 "}\n"
2828 "set types {}\n"
2829 "foreach t $string {\n"
2830 "set label [lindex $t 0]\n"
2831 "set exts {}\n"
2832 "if {[info exists hasDoneType($label)]} {\n"
2833 "continue\n"
2834 "}\n"
2835 "set name \"$label (\"\n"
2836 "set sep \"\"\n"
2837 "foreach ext $fileTypes($label) {\n"
2838 "if {[string equal $ext \"\"]} {\n"
2839 "continue\n"
2840 "}\n"
2841 "regsub {^[.]} $ext \"*.\" ext\n"
2842 "if {![info exists hasGotExt($label,$ext)]} {\n"
2843 "append name $sep$ext\n"
2844 "lappend exts $ext\n"
2845 "set hasGotExt($label,$ext) 1\n"
2846 "}\n"
2847 "set sep ,\n"
2848 "}\n"
2849 "append name \")\"\n"
2850 "lappend types [list $name $exts]\n"
2851 "set hasDoneType($label) 1\n"
2852 "}\n"
2853 "return $types\n"
2854 "}\n"
2855 ;
2856 static char Et_zFile12[] =
2857 "proc tkConsoleInit {} {\n"
2858 "global tcl_platform\n"
2859 "if {![consoleinterp eval {set tcl_interactive}]} {\n"
2860 "wm withdraw .\n"
2861 "}\n"
2862 "if {[string compare $tcl_platform(platform) \"macintosh\"]} {\n"
2863 "set mod \"Ctrl\"\n"
2864 "} else {\n"
2865 "set mod \"Cmd\"\n"
2866 "}\n"
2867 "menu .menubar\n"
2868 ".menubar add cascade -label File -menu .menubar.file -underline 0\n"
2869 ".menubar add cascade -label Edit -menu .menubar.edit -underline 0\n"
2870 "menu .menubar.file -tearoff 0\n"
2871 ".menubar.file add command -label \"Source...\" -underline 0 \\\n"
2872 "\011 -command tkConsoleSource\n"
2873 ".menubar.file add command -label \"Hide Console\" -underline 0 \\\n"
2874 "\011 -command {wm withdraw .}\n"
2875 "if {[string compare $tcl_platform(platform) \"macintosh\"]} {\n"
2876 ".menubar.file add command -label \"Exit\" -underline 1 -command exit\n"
2877 "} else {\n"
2878 ".menubar.file add command -label \"Quit\" -command exit -accel Cmd-Q\n"
2879 "}\n"
2880 "menu .menubar.edit -tearoff 0\n"
2881 ".menubar.edit add command -label \"Cut\" -underline 2 \\\n"
2882 "\011 -command { event generate .console <<Cut>> } -accel \"$mod+X\"\n"
2883 ".menubar.edit add command -label \"Copy\" -underline 0 \\\n"
2884 "\011 -command { event generate .console <<Copy>> } -accel \"$mod+C\"\n"
2885 ".menubar.edit add command -label \"Paste\" -underline 1 \\\n"
2886 "\011 -command { event generate .console <<Paste>> } -accel \"$mod+V\"\n"
2887 "if {[string compare $tcl_platform(platform) \"windows\"]} {\n"
2888 ".menubar.edit add command -label \"Clear\" -underline 2 \\\n"
2889 "\011\011-command { event generate .console <<Clear>> }\n"
2890 "} else {\n"
2891 ".menubar.edit add command -label \"Delete\" -underline 0 \\\n"
2892 "\011\011-command { event generate .console <<Clear>> } -accel \"Del\"\n"
2893 ".menubar add cascade -label Help -menu .menubar.help -underline 0\n"
2894 "menu .menubar.help -tearoff 0\n"
2895 ".menubar.help add command -label \"About...\" -underline 0 \\\n"
2896 "\011\011-command tkConsoleAbout\n"
2897 "}\n"
2898 ". configure -menu .menubar\n"
2899 "text .console -yscrollcommand \".sb set\" -setgrid true \n"
2900 "scrollbar .sb -command \".console yview\"\n"
2901 "pack .sb -side right -fill both\n"
2902 "pack .console -fill both -expand 1 -side left\n"
2903 "switch -exact $tcl_platform(platform) {\n"
2904 "\"macintosh\" {\n"
2905 ".console configure -font {Monaco 9 normal} -highlightthickness 0\n"
2906 "}\n"
2907 "\"windows\" {\n"
2908 ".console configure -font systemfixed\n"
2909 "}\n"
2910 "}\n"
2911 "tkConsoleBind .console\n"
2912 ".console tag configure stderr -foreground red\n"
2913 ".console tag configure stdin -foreground blue\n"
2914 "focus .console\n"
2915 "wm protocol . WM_DELETE_WINDOW { wm withdraw . }\n"
2916 "wm title . \"" BUILD_CONFIG_STATIC_WISH_ALIAS " v" BUILD_CONFIG_RELEASE_VERSION "\"\n"
2917 "flush stdout\n"
2918 ".console mark set output [.console index \"end - 1 char\"]\n"
2919 "tkTextSetCursor .console end\n"
2920 ".console mark set promptEnd insert\n"
2921 ".console mark gravity promptEnd left\n"
2922 "}\n"
2923 "proc tkConsoleSource {} {\n"
2924 "set filename [tk_getOpenFile -defaultextension .tcl -parent . \\\n"
2925 "\011\011 -title \"Select a file to source\" \\\n"
2926 "\011\011 -filetypes {{\"Tcl Scripts\" .tcl} {\"All Files\" *}}]\n"
2927 "if {[string compare $filename \"\"]} {\n"
2928 "set cmd [list source $filename]\n"
2929 "if {[catch {consoleinterp eval $cmd} result]} {\n"
2930 "tkConsoleOutput stderr \"$result\\n\"\n"
2931 "}\n"
2932 "}\n"
2933 "}\n"
2934 "proc tkConsoleInvoke {args} {\n"
2935 "set ranges [.console tag ranges input]\n"
2936 "set cmd \"\"\n"
2937 "if {[llength $ranges]} {\n"
2938 "set pos 0\n"
2939 "while {[string compare [lindex $ranges $pos] \"\"]} {\n"
2940 "set start [lindex $ranges $pos]\n"
2941 "set end [lindex $ranges [incr pos]]\n"
2942 "append cmd [.console get $start $end]\n"
2943 "incr pos\n"
2944 "}\n"
2945 "}\n"
2946 "if {[string equal $cmd \"\"]} {\n"
2947 "tkConsolePrompt\n"
2948 "} elseif {[info complete $cmd]} {\n"
2949 ".console mark set output end\n"
2950 ".console tag delete input\n"
2951 "set result [consoleinterp record $cmd]\n"
2952 "if {[string compare $result \"\"]} {\n"
2953 "puts $result\n"
2954 "}\n"
2955 "tkConsoleHistory reset\n"
2956 "tkConsolePrompt\n"
2957 "} else {\n"
2958 "tkConsolePrompt partial\n"
2959 "}\n"
2960 ".console yview -pickplace insert\n"
2961 "}\n"
2962 "set histNum 1\n"
2963 "proc tkConsoleHistory {cmd} {\n"
2964 "global histNum\n"
2965 "switch $cmd {\n"
2966 "prev {\n"
2967 "incr histNum -1\n"
2968 "if {$histNum == 0} {\n"
2969 "set cmd {history event [expr {[history nextid] -1}]}\n"
2970 "} else {\n"
2971 "set cmd \"history event $histNum\"\n"
2972 "}\n"
2973 "if {[catch {consoleinterp eval $cmd} cmd]} {\n"
2974 "incr histNum\n"
2975 "return\n"
2976 "}\n"
2977 ".console delete promptEnd end\n"
2978 ".console insert promptEnd $cmd {input stdin}\n"
2979 "}\n"
2980 "next {\n"
2981 "incr histNum\n"
2982 "if {$histNum == 0} {\n"
2983 "set cmd {history event [expr {[history nextid] -1}]}\n"
2984 "} elseif {$histNum > 0} {\n"
2985 "set cmd \"\"\n"
2986 "set histNum 1\n"
2987 "} else {\n"
2988 "set cmd \"history event $histNum\"\n"
2989 "}\n"
2990 "if {[string compare $cmd \"\"]} {\n"
2991 "catch {consoleinterp eval $cmd} cmd\n"
2992 "}\n"
2993 ".console delete promptEnd end\n"
2994 ".console insert promptEnd $cmd {input stdin}\n"
2995 "}\n"
2996 "reset {\n"
2997 "set histNum 1\n"
2998 "}\n"
2999 "}\n"
3000 "}\n"
3001 "proc tkConsolePrompt {{partial normal}} {\n"
3002 "if {[string equal $partial \"normal\"]} {\n"
3003 "set temp [.console index \"end - 1 char\"]\n"
3004 ".console mark set output end\n"
3005 "if {[consoleinterp eval \"info exists tcl_prompt1\"]} {\n"
3006 "consoleinterp eval \"eval \\[set tcl_prompt1\\]\"\n"
3007 "} else {\n"
3008 "puts -nonewline \"% \"\n"
3009 "}\n"
3010 "} else {\n"
3011 "set temp [.console index output]\n"
3012 ".console mark set output end\n"
3013 "if {[consoleinterp eval \"info exists tcl_prompt2\"]} {\n"
3014 "consoleinterp eval \"eval \\[set tcl_prompt2\\]\"\n"
3015 "} else {\n"
3016 "puts -nonewline \"> \"\n"
3017 "}\n"
3018 "}\n"
3019 "flush stdout\n"
3020 ".console mark set output $temp\n"
3021 "tkTextSetCursor .console end\n"
3022 ".console mark set promptEnd insert\n"
3023 ".console mark gravity promptEnd left\n"
3024 "}\n"
3025 "proc tkConsoleBind {win} {\n"
3026 "bindtags $win \"$win Text . all\"\n"
3027 "bind $win <Alt-KeyPress> {# nothing }\n"
3028 "bind $win <Meta-KeyPress> {# nothing}\n"
3029 "bind $win <Control-KeyPress> {# nothing}\n"
3030 "bind $win <Escape> {# nothing}\n"
3031 "bind $win <KP_Enter> {# nothing}\n"
3032 "bind $win <Tab> {\n"
3033 "tkConsoleInsert %W \\t\n"
3034 "focus %W\n"
3035 "break\n"
3036 "}\n"
3037 "bind $win <Return> {\n"
3038 "%W mark set insert {end - 1c}\n"
3039 "tkConsoleInsert %W \"\\n\"\n"
3040 "tkConsoleInvoke\n"
3041 "break\n"
3042 "}\n"
3043 "bind $win <Delete> {\n"
3044 "if {[string compare [%W tag nextrange sel 1.0 end] \"\"]} {\n"
3045 "%W tag remove sel sel.first promptEnd\n"
3046 "} elseif {[%W compare insert < promptEnd]} {\n"
3047 "break\n"
3048 "}\n"
3049 "}\n"
3050 "bind $win <BackSpace> {\n"
3051 "if {[string compare [%W tag nextrange sel 1.0 end] \"\"]} {\n"
3052 "%W tag remove sel sel.first promptEnd\n"
3053 "} elseif {[%W compare insert <= promptEnd]} {\n"
3054 "break\n"
3055 "}\n"
3056 "}\n"
3057 "foreach left {Control-a Home} {\n"
3058 "bind $win <$left> {\n"
3059 "if {[%W compare insert < promptEnd]} {\n"
3060 "tkTextSetCursor %W {insert linestart}\n"
3061 "} else {\n"
3062 "tkTextSetCursor %W promptEnd\n"
3063 "}\n"
3064 "break\n"
3065 "}\n"
3066 "}\n"
3067 "foreach right {Control-e End} {\n"
3068 "bind $win <$right> {\n"
3069 "tkTextSetCursor %W {insert lineend}\n"
3070 "break\n"
3071 "}\n"
3072 "}\n"
3073 "bind $win <Control-d> {\n"
3074 "if {[%W compare insert < promptEnd]} {\n"
3075 "break\n"
3076 "}\n"
3077 "}\n"
3078 "bind $win <Control-k> {\n"
3079 "if {[%W compare insert < promptEnd]} {\n"
3080 "%W mark set insert promptEnd\n"
3081 "}\n"
3082 "}\n"
3083 "bind $win <Control-t> {\n"
3084 "if {[%W compare insert < promptEnd]} {\n"
3085 "break\n"
3086 "}\n"
3087 "}\n"
3088 "bind $win <Meta-d> {\n"
3089 "if {[%W compare insert < promptEnd]} {\n"
3090 "break\n"
3091 "}\n"
3092 "}\n"
3093 "bind $win <Meta-BackSpace> {\n"
3094 "if {[%W compare insert <= promptEnd]} {\n"
3095 "break\n"
3096 "}\n"
3097 "}\n"
3098 "bind $win <Control-h> {\n"
3099 "if {[%W compare insert <= promptEnd]} {\n"
3100 "break\n"
3101 "}\n"
3102 "}\n"
3103 "foreach prev {Control-p Up} {\n"
3104 "bind $win <$prev> {\n"
3105 "tkConsoleHistory prev\n"
3106 "break\n"
3107 "}\n"
3108 "}\n"
3109 "foreach prev {Control-n Down} {\n"
3110 "bind $win <$prev> {\n"
3111 "tkConsoleHistory next\n"
3112 "break\n"
3113 "}\n"
3114 "}\n"
3115 "bind $win <Insert> {\n"
3116 "catch {tkConsoleInsert %W [selection get -displayof %W]}\n"
3117 "break\n"
3118 "}\n"
3119 "bind $win <KeyPress> {\n"
3120 "tkConsoleInsert %W %A\n"
3121 "break\n"
3122 "}\n"
3123 "foreach left {Control-b Left} {\n"
3124 "bind $win <$left> {\n"
3125 "if {[%W compare insert == promptEnd]} {\n"
3126 "break\n"
3127 "}\n"
3128 "tkTextSetCursor %W insert-1c\n"
3129 "break\n"
3130 "}\n"
3131 "}\n"
3132 "foreach right {Control-f Right} {\n"
3133 "bind $win <$right> {\n"
3134 "tkTextSetCursor %W insert+1c\n"
3135 "break\n"
3136 "}\n"
3137 "}\n"
3138 "bind $win <F9> {\n"
3139 "eval destroy [winfo child .]\n"
3140 "if {[string equal $tcl_platform(platform) \"macintosh\"]} {\n"
3141 "source -rsrc Console\n"
3142 "} else {\n"
3143 "source [file join $tk_library console.tcl]\n"
3144 "}\n"
3145 "}\n"
3146 "bind $win <<Cut>> {\n"
3147 "if {![catch {set data [%W get sel.first sel.last]}]} {\n"
3148 "clipboard clear -displayof %W\n"
3149 "clipboard append -displayof %W $data\n"
3150 "}\n"
3151 "break\n"
3152 "}\n"
3153 "bind $win <<Copy>> {\n"
3154 "if {![catch {set data [%W get sel.first sel.last]}]} {\n"
3155 "clipboard clear -displayof %W\n"
3156 "clipboard append -displayof %W $data\n"
3157 "}\n"
3158 "break\n"
3159 "}\n"
3160 "bind $win <<Paste>> {\n"
3161 "catch {\n"
3162 "set clip [selection get -displayof %W -selection CLIPBOARD]\n"
3163 "set list [split $clip \\n\\r]\n"
3164 "tkConsoleInsert %W [lindex $list 0]\n"
3165 "foreach x [lrange $list 1 end] {\n"
3166 "%W mark set insert {end - 1c}\n"
3167 "tkConsoleInsert %W \"\\n\"\n"
3168 "tkConsoleInvoke\n"
3169 "tkConsoleInsert %W $x\n"
3170 "}\n"
3171 "}\n"
3172 "break\n"
3173 "}\n"
3174 "}\n"
3175 "proc tkConsoleInsert {w s} {\n"
3176 "if {[string equal $s \"\"]} {\n"
3177 "return\n"
3178 "}\n"
3179 "catch {\n"
3180 "if {[$w compare sel.first <= insert]\n"
3181 "&& [$w compare sel.last >= insert]} {\n"
3182 "$w tag remove sel sel.first promptEnd\n"
3183 "$w delete sel.first sel.last\n"
3184 "}\n"
3185 "}\n"
3186 "if {[$w compare insert < promptEnd]} {\n"
3187 "$w mark set insert end\011\n"
3188 "}\n"
3189 "$w insert insert $s {input stdin}\n"
3190 "$w see insert\n"
3191 "}\n"
3192 "proc tkConsoleOutput {dest string} {\n"
3193 ".console insert output $string $dest\n"
3194 ".console see insert\n"
3195 "}\n"
3196 "proc tkConsoleExit {} {\n"
3197 "destroy .\n"
3198 "}\n"
3199 "proc tkConsoleAbout {} {\n"
3200 "global tk_patchLevel\n"
3201 "tk_messageBox -type ok -message \""
3202 BUILD_CONFIG_STATIC_WISH_ALIAS
3203 " for Windows, Version "
3204 BUILD_CONFIG_RELEASE_VERSION ", " BUILD_CONFIG_RELEASE_YEAR ".\n"
3205 "This product is an open-source static port of\n"
3206 "Tcl/Tk 8.3.1, originally from Scriptics. This product\n"
3207 "and its source code can be downloaded at no charge\n"
3208 "from http://ijutools.sourceforge.net, and is licensed\n"
3209 "under the GNU Public License (GPL).\n"
3210 "(Core components: Tcl [info patchlevel], Tk $tk_patchLevel.)\"\n"
3211 "}\n"
3212 "tkConsoleInit\n"
3213 ;
3214 static char Et_zFile13[] =
3215 "proc tk_dialog {w title text bitmap default args} {\n"
3216 "global tkPriv tcl_platform\n"
3217 "if {[string is int $default]} {\n"
3218 "if {$default >= [llength $args]} {\n"
3219 "return -code error \"default button index greater than number of\\\n"
3220 "\011\011 buttons specified for tk_dialog\"\n"
3221 "}\n"
3222 "} elseif {[string equal {} $default]} {\n"
3223 "set default -1\n"
3224 "} else {\n"
3225 "set default [lsearch -exact $args $default]\n"
3226 "}\n"
3227 "catch {destroy $w}\n"
3228 "toplevel $w -class Dialog\n"
3229 "wm title $w $title\n"
3230 "wm iconname $w Dialog\n"
3231 "wm protocol $w WM_DELETE_WINDOW { }\n"
3232 "if { [winfo viewable [winfo toplevel [winfo parent $w]]] } {\n"
3233 "wm transient $w [winfo toplevel [winfo parent $w]]\n"
3234 "} \n"
3235 "if {[string equal $tcl_platform(platform) \"macintosh\"]} {\n"
3236 "unsupported1 style $w dBoxProc\n"
3237 "}\n"
3238 "frame $w.bot\n"
3239 "frame $w.top\n"
3240 "if {[string equal $tcl_platform(platform) \"unix\"]} {\n"
3241 "$w.bot configure -relief raised -bd 1\n"
3242 "$w.top configure -relief raised -bd 1\n"
3243 "}\n"
3244 "pack $w.bot -side bottom -fill both\n"
3245 "pack $w.top -side top -fill both -expand 1\n"
3246 "option add *Dialog.msg.wrapLength 3i widgetDefault\n"
3247 "if {[string equal $tcl_platform(platform) \"macintosh\"]} {\n"
3248 "option add *Dialog.msg.font system widgetDefault\n"
3249 "} else {\n"
3250 "option add *Dialog.msg.font {Times 12} widgetDefault\n"
3251 "}\n"
3252 "label $w.msg -justify left -text $text\n"
3253 "pack $w.msg -in $w.top -side right -expand 1 -fill both -padx 3m -pady 3m\n"
3254 "if {[string compare $bitmap \"\"]} {\n"
3255 "if {[string equal $tcl_platform(platform) \"macintosh\"] && \\\n"
3256 "\011\011[string equal $bitmap \"error\"]} {\n"
3257 "set bitmap \"stop\"\n"
3258 "}\n"
3259 "label $w.bitmap -bitmap $bitmap\n"
3260 "pack $w.bitmap -in $w.top -side left -padx 3m -pady 3m\n"
3261 "}\n"
3262 "set i 0\n"
3263 "foreach but $args {\n"
3264 "button $w.button$i -text $but -command [list set tkPriv(button) $i]\n"
3265 "if {$i == $default} {\n"
3266 "$w.button$i configure -default active\n"
3267 "} else {\n"
3268 "$w.button$i configure -default normal\n"
3269 "}\n"
3270 "grid $w.button$i -in $w.bot -column $i -row 0 -sticky ew -padx 10\n"
3271 "grid columnconfigure $w.bot $i\n"
3272 "if {[string equal $tcl_platform(platform) \"macintosh\"]} {\n"
3273 "set tmp [string tolower $but]\n"
3274 "if {[string equal $tmp \"ok\"] || [string equal $tmp \"cancel\"]} {\n"
3275 "grid columnconfigure $w.bot $i -minsize [expr {59 + 20}]\n"
3276 "}\n"
3277 "}\n"
3278 "incr i\n"
3279 "}\n"
3280 "if {$default >= 0} {\n"
3281 "bind $w <Return> \"\n"
3282 "[list $w.button$default] configure -state active -relief sunken\n"
3283 "update idletasks\n"
3284 "after 100\n"
3285 "set tkPriv(button) $default\n"
3286 "\"\n"
3287 "}\n"
3288 "bind $w <Destroy> {set tkPriv(button) -1}\n"
3289 "wm withdraw $w\n"
3290 "update idletasks\n"
3291 "set x [expr {[winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \\\n"
3292 "\011 - [winfo vrootx [winfo parent $w]]}]\n"
3293 "set y [expr {[winfo screenheight $w]/2 - [winfo reqheight $w]/2 \\\n"
3294 "\011 - [winfo vrooty [winfo parent $w]]}]\n"
3295 "wm geom $w +$x+$y\n"
3296 "wm deiconify $w\n"
3297 "set oldFocus [focus]\n"
3298 "set oldGrab [grab current $w]\n"
3299 "if {[string compare $oldGrab \"\"]} {\n"
3300 "set grabStatus [grab status $oldGrab]\n"
3301 "}\n"
3302 "grab $w\n"
3303 "if {$default >= 0} {\n"
3304 "focus $w.button$default\n"
3305 "} else {\n"
3306 "focus $w\n"
3307 "}\n"
3308 "tkwait variable tkPriv(button)\n"
3309 "catch {focus $oldFocus}\n"
3310 "catch {\n"
3311 "bind $w <Destroy> {}\n"
3312 "destroy $w\n"
3313 "}\n"
3314 "if {[string compare $oldGrab \"\"]} {\n"
3315 "if {[string compare $grabStatus \"global\"]} {\n"
3316 "grab $oldGrab\n"
3317 "} else {\n"
3318 "grab -global $oldGrab\n"
3319 "}\n"
3320 "}\n"
3321 "return $tkPriv(button)\n"
3322 "}\n"
3323 ;
3324 static char Et_zFile14[] =
3325 "bind Entry <<Cut>> {\n"
3326 "if {![catch {tkEntryGetSelection %W} tkPriv(data)]} {\n"
3327 "clipboard clear -displayof %W\n"
3328 "clipboard append -displayof %W $tkPriv(data)\n"
3329 "%W delete sel.first sel.last\n"
3330 "unset tkPriv(data)\n"
3331 "}\n"
3332 "}\n"
3333 "bind Entry <<Copy>> {\n"
3334 "if {![catch {tkEntryGetSelection %W} tkPriv(data)]} {\n"
3335 "clipboard clear -displayof %W\n"
3336 "clipboard append -displayof %W $tkPriv(data)\n"
3337 "unset tkPriv(data)\n"
3338 "}\n"
3339 "}\n"
3340 "bind Entry <<Paste>> {\n"
3341 "global tcl_platform\n"
3342 "catch {\n"
3343 "if {[string compare $tcl_platform(platform) \"unix\"]} {\n"
3344 "catch {\n"
3345 "%W delete sel.first sel.last\n"
3346 "}\n"
3347 "}\n"
3348 "%W insert insert [selection get -displayof %W -selection CLIPBOARD]\n"
3349 "tkEntrySeeInsert %W\n"
3350 "}\n"
3351 "}\n"
3352 "bind Entry <<Clear>> {\n"
3353 "%W delete sel.first sel.last\n"
3354 "}\n"
3355 "bind Entry <<PasteSelection>> {\n"
3356 "if {!$tkPriv(mouseMoved) || $tk_strictMotif} {\n"
3357 "tkEntryPaste %W %x\n"
3358 "}\n"
3359 "}\n"
3360 "bind Entry <1> {\n"
3361 "tkEntryButton1 %W %x\n"
3362 "%W selection clear\n"
3363 "}\n"
3364 "bind Entry <B1-Motion> {\n"
3365 "set tkPriv(x) %x\n"
3366 "tkEntryMouseSelect %W %x\n"
3367 "}\n"
3368 "bind Entry <Double-1> {\n"
3369 "set tkPriv(selectMode) word\n"
3370 "tkEntryMouseSelect %W %x\n"
3371 "catch {%W icursor sel.first}\n"
3372 "}\n"
3373 "bind Entry <Triple-1> {\n"
3374 "set tkPriv(selectMode) line\n"
3375 "tkEntryMouseSelect %W %x\n"
3376 "%W icursor 0\n"
3377 "}\n"
3378 "bind Entry <Shift-1> {\n"
3379 "set tkPriv(selectMode) char\n"
3380 "%W selection adjust @%x\n"
3381 "}\n"
3382 "bind Entry <Double-Shift-1>\011{\n"
3383 "set tkPriv(selectMode) word\n"
3384 "tkEntryMouseSelect %W %x\n"
3385 "}\n"
3386 "bind Entry <Triple-Shift-1>\011{\n"
3387 "set tkPriv(selectMode) line\n"
3388 "tkEntryMouseSelect %W %x\n"
3389 "}\n"
3390 "bind Entry <B1-Leave> {\n"
3391 "set tkPriv(x) %x\n"
3392 "tkEntryAutoScan %W\n"
3393 "}\n"
3394 "bind Entry <B1-Enter> {\n"
3395 "tkCancelRepeat\n"
3396 "}\n"
3397 "bind Entry <ButtonRelease-1> {\n"
3398 "tkCancelRepeat\n"
3399 "}\n"
3400 "bind Entry <Control-1> {\n"
3401 "%W icursor @%x\n"
3402 "}\n"
3403 "bind Entry <Left> {\n"
3404 "tkEntrySetCursor %W [expr {[%W index insert] - 1}]\n"
3405 "}\n"
3406 "bind Entry <Right> {\n"
3407 "tkEntrySetCursor %W [expr {[%W index insert] + 1}]\n"
3408 "}\n"
3409 "bind Entry <Shift-Left> {\n"
3410 "tkEntryKeySelect %W [expr {[%W index insert] - 1}]\n"
3411 "tkEntrySeeInsert %W\n"
3412 "}\n"
3413 "bind Entry <Shift-Right> {\n"
3414 "tkEntryKeySelect %W [expr {[%W index insert] + 1}]\n"
3415 "tkEntrySeeInsert %W\n"
3416 "}\n"
3417 "bind Entry <Control-Left> {\n"
3418 "tkEntrySetCursor %W [tkEntryPreviousWord %W insert]\n"
3419 "}\n"
3420 "bind Entry <Control-Right> {\n"
3421 "tkEntrySetCursor %W [tkEntryNextWord %W insert]\n"
3422 "}\n"
3423 "bind Entry <Shift-Control-Left> {\n"
3424 "tkEntryKeySelect %W [tkEntryPreviousWord %W insert]\n"
3425 "tkEntrySeeInsert %W\n"
3426 "}\n"
3427 "bind Entry <Shift-Control-Right> {\n"
3428 "tkEntryKeySelect %W [tkEntryNextWord %W insert]\n"
3429 "tkEntrySeeInsert %W\n"
3430 "}\n"
3431 "bind Entry <Home> {\n"
3432 "tkEntrySetCursor %W 0\n"
3433 "}\n"
3434 "bind Entry <Shift-Home> {\n"
3435 "tkEntryKeySelect %W 0\n"
3436 "tkEntrySeeInsert %W\n"
3437 "}\n"
3438 "bind Entry <End> {\n"
3439 "tkEntrySetCursor %W end\n"
3440 "}\n"
3441 "bind Entry <Shift-End> {\n"
3442 "tkEntryKeySelect %W end\n"
3443 "tkEntrySeeInsert %W\n"
3444 "}\n"
3445 "bind Entry <Delete> {\n"
3446 "if {[%W selection present]} {\n"
3447 "%W delete sel.first sel.last\n"
3448 "} else {\n"
3449 "%W delete insert\n"
3450 "}\n"
3451 "}\n"
3452 "bind Entry <BackSpace> {\n"
3453 "tkEntryBackspace %W\n"
3454 "}\n"
3455 "bind Entry <Control-space> {\n"
3456 "%W selection from insert\n"
3457 "}\n"
3458 "bind Entry <Select> {\n"
3459 "%W selection from insert\n"
3460 "}\n"
3461 "bind Entry <Control-Shift-space> {\n"
3462 "%W selection adjust insert\n"
3463 "}\n"
3464 "bind Entry <Shift-Select> {\n"
3465 "%W selection adjust insert\n"
3466 "}\n"
3467 "bind Entry <Control-slash> {\n"
3468 "%W selection range 0 end\n"
3469 "}\n"
3470 "bind Entry <Control-backslash> {\n"
3471 "%W selection clear\n"
3472 "}\n"
3473 "bind Entry <KeyPress> {\n"
3474 "tkEntryInsert %W %A\n"
3475 "}\n"
3476 "bind Entry <Alt-KeyPress> {# nothing}\n"
3477 "bind Entry <Meta-KeyPress> {# nothing}\n"
3478 "bind Entry <Control-KeyPress> {# nothing}\n"
3479 "bind Entry <Escape> {# nothing}\n"
3480 "bind Entry <Return> {# nothing}\n"
3481 "bind Entry <KP_Enter> {# nothing}\n"
3482 "bind Entry <Tab> {# nothing}\n"
3483 "if {[string equal $tcl_platform(platform) \"macintosh\"]} {\n"
3484 "bind Entry <Command-KeyPress> {# nothing}\n"
3485 "}\n"
3486 "if {[string compare $tcl_platform(platform) \"windows\"]} {\n"
3487 "bind Entry <Insert> {\n"
3488 "catch {tkEntryInsert %W [selection get -displayof %W]}\n"
3489 "}\n"
3490 "}\n"
3491 "bind Entry <Control-a> {\n"
3492 "if {!$tk_strictMotif} {\n"
3493 "tkEntrySetCursor %W 0\n"
3494 "}\n"
3495 "}\n"
3496 "bind Entry <Control-b> {\n"
3497 "if {!$tk_strictMotif} {\n"
3498 "tkEntrySetCursor %W [expr {[%W index insert] - 1}]\n"
3499 "}\n"
3500 "}\n"
3501 "bind Entry <Control-d> {\n"
3502 "if {!$tk_strictMotif} {\n"
3503 "%W delete insert\n"
3504 "}\n"
3505 "}\n"
3506 "bind Entry <Control-e> {\n"
3507 "if {!$tk_strictMotif} {\n"
3508 "tkEntrySetCursor %W end\n"
3509 "}\n"
3510 "}\n"
3511 "bind Entry <Control-f> {\n"
3512 "if {!$tk_strictMotif} {\n"
3513 "tkEntrySetCursor %W [expr {[%W index insert] + 1}]\n"
3514 "}\n"
3515 "}\n"
3516 "bind Entry <Control-h> {\n"
3517 "if {!$tk_strictMotif} {\n"
3518 "tkEntryBackspace %W\n"
3519 "}\n"
3520 "}\n"
3521 "bind Entry <Control-k> {\n"
3522 "if {!$tk_strictMotif} {\n"
3523 "%W delete insert end\n"
3524 "}\n"
3525 "}\n"
3526 "bind Entry <Control-t> {\n"
3527 "if {!$tk_strictMotif} {\n"
3528 "tkEntryTranspose %W\n"
3529 "}\n"
3530 "}\n"
3531 "bind Entry <Meta-b> {\n"
3532 "if {!$tk_strictMotif} {\n"
3533 "tkEntrySetCursor %W [tkEntryPreviousWord %W insert]\n"
3534 "}\n"
3535 "}\n"
3536 "bind Entry <Meta-d> {\n"
3537 "if {!$tk_strictMotif} {\n"
3538 "%W delete insert [tkEntryNextWord %W insert]\n"
3539 "}\n"
3540 "}\n"
3541 "bind Entry <Meta-f> {\n"
3542 "if {!$tk_strictMotif} {\n"
3543 "tkEntrySetCursor %W [tkEntryNextWord %W insert]\n"
3544 "}\n"
3545 "}\n"
3546 "bind Entry <Meta-BackSpace> {\n"
3547 "if {!$tk_strictMotif} {\n"
3548 "%W delete [tkEntryPreviousWord %W insert] insert\n"
3549 "}\n"
3550 "}\n"
3551 "bind Entry <Meta-Delete> {\n"
3552 "if {!$tk_strictMotif} {\n"
3553 "%W delete [tkEntryPreviousWord %W insert] insert\n"
3554 "}\n"
3555 "}\n"
3556 "bind Entry <2> {\n"
3557 "if {!$tk_strictMotif} {\n"
3558 "%W scan mark %x\n"
3559 "set tkPriv(x) %x\n"
3560 "set tkPriv(y) %y\n"
3561 "set tkPriv(mouseMoved) 0\n"
3562 "}\n"
3563 "}\n"
3564 "bind Entry <B2-Motion> {\n"
3565 "if {!$tk_strictMotif} {\n"
3566 "if {abs(%x-$tkPriv(x)) > 2} {\n"
3567 "set tkPriv(mouseMoved) 1\n"
3568 "}\n"
3569 "%W scan dragto %x\n"
3570 "}\n"
3571 "}\n"
3572 "proc tkEntryClosestGap {w x} {\n"
3573 "set pos [$w index @$x]\n"
3574 "set bbox [$w bbox $pos]\n"
3575 "if {($x - [lindex $bbox 0]) < ([lindex $bbox 2]/2)} {\n"
3576 "return $pos\n"
3577 "}\n"
3578 "incr pos\n"
3579 "}\n"
3580 "proc tkEntryButton1 {w x} {\n"
3581 "global tkPriv\n"
3582 "set tkPriv(selectMode) char\n"
3583 "set tkPriv(mouseMoved) 0\n"
3584 "set tkPriv(pressX) $x\n"
3585 "$w icursor [tkEntryClosestGap $w $x]\n"
3586 "$w selection from insert\n"
3587 "if {[string equal [$w cget -state] \"normal\"]} {focus $w}\n"
3588 "}\n"
3589 "proc tkEntryMouseSelect {w x} {\n"
3590 "global tkPriv\n"
3591 "set cur [tkEntryClosestGap $w $x]\n"
3592 "set anchor [$w index anchor]\n"
3593 "if {($cur != $anchor) || (abs($tkPriv(pressX) - $x) >= 3)} {\n"
3594 "set tkPriv(mouseMoved) 1\n"
3595 "}\n"
3596 "switch $tkPriv(selectMode) {\n"
3597 "char {\n"
3598 "if {$tkPriv(mouseMoved)} {\n"
3599 "if {$cur < $anchor} {\n"
3600 "$w selection range $cur $anchor\n"
3601 "} elseif {$cur > $anchor} {\n"
3602 "$w selection range $anchor $cur\n"
3603 "} else {\n"
3604 "$w selection clear\n"
3605 "}\n"
3606 "}\n"
3607 "}\n"
3608 "word {\n"
3609 "if {$cur < [$w index anchor]} {\n"
3610 "set before [tcl_wordBreakBefore [$w get] $cur]\n"
3611 "set after [tcl_wordBreakAfter [$w get] [expr {$anchor-1}]]\n"
3612 "} else {\n"
3613 "set before [tcl_wordBreakBefore [$w get] $anchor]\n"
3614 "set after [tcl_wordBreakAfter [$w get] [expr {$cur - 1}]]\n"
3615 "}\n"
3616 "if {$before < 0} {\n"
3617 "set before 0\n"
3618 "}\n"
3619 "if {$after < 0} {\n"
3620 "set after end\n"
3621 "}\n"
3622 "$w selection range $before $after\n"
3623 "}\n"
3624 "line {\n"
3625 "$w selection range 0 end\n"
3626 "}\n"
3627 "}\n"
3628 "update idletasks\n"
3629 "}\n"
3630 "proc tkEntryPaste {w x} {\n"
3631 "global tkPriv\n"
3632 "$w icursor [tkEntryClosestGap $w $x]\n"
3633 "catch {$w insert insert [selection get -displayof $w]}\n"
3634 "if {[string equal [$w cget -state] \"normal\"]} {focus $w}\n"
3635 "}\n"
3636 "proc tkEntryAutoScan {w} {\n"
3637 "global tkPriv\n"
3638 "set x $tkPriv(x)\n"
3639 "if {![winfo exists $w]} return\n"
3640 "if {$x >= [winfo width $w]} {\n"
3641 "$w xview scroll 2 units\n"
3642 "tkEntryMouseSelect $w $x\n"
3643 "} elseif {$x < 0} {\n"
3644 "$w xview scroll -2 units\n"
3645 "tkEntryMouseSelect $w $x\n"
3646 "}\n"
3647 "set tkPriv(afterId) [after 50 [list tkEntryAutoScan $w]]\n"
3648 "}\n"
3649 "proc tkEntryKeySelect {w new} {\n"
3650 "if {![$w selection present]} {\n"
3651 "$w selection from insert\n"
3652 "$w selection to $new\n"
3653 "} else {\n"
3654 "$w selection adjust $new\n"
3655 "}\n"
3656 "$w icursor $new\n"
3657 "}\n"
3658 "proc tkEntryInsert {w s} {\n"
3659 "if {[string equal $s \"\"]} {\n"
3660 "return\n"
3661 "}\n"
3662 "catch {\n"
3663 "set insert [$w index insert]\n"
3664 "if {([$w index sel.first] <= $insert)\n"
3665 "&& ([$w index sel.last] >= $insert)} {\n"
3666 "$w delete sel.first sel.last\n"
3667 "}\n"
3668 "}\n"
3669 "$w insert insert $s\n"
3670 "tkEntrySeeInsert $w\n"
3671 "}\n"
3672 "proc tkEntryBackspace w {\n"
3673 "if {[$w selection present]} {\n"
3674 "$w delete sel.first sel.last\n"
3675 "} else {\n"
3676 "set x [expr {[$w index insert] - 1}]\n"
3677 "if {$x >= 0} {$w delete $x}\n"
3678 "if {[$w index @0] >= [$w index insert]} {\n"
3679 "set range [$w xview]\n"
3680 "set left [lindex $range 0]\n"
3681 "set right [lindex $range 1]\n"
3682 "$w xview moveto [expr {$left - ($right - $left)/2.0}]\n"
3683 "}\n"
3684 "}\n"
3685 "}\n"
3686 "proc tkEntrySeeInsert w {\n"
3687 "set c [$w index insert]\n"
3688 "if {($c < [$w index @0]) || ($c > [$w index @[winfo width $w]])} {\n"
3689 "$w xview $c\n"
3690 "}\n"
3691 "}\n"
3692 "proc tkEntrySetCursor {w pos} {\n"
3693 "$w icursor $pos\n"
3694 "$w selection clear\n"
3695 "tkEntrySeeInsert $w\n"
3696 "}\n"
3697 "proc tkEntryTranspose w {\n"
3698 "set i [$w index insert]\n"
3699 "if {$i < [$w index end]} {\n"
3700 "incr i\n"
3701 "}\n"
3702 "set first [expr {$i-2}]\n"
3703 "if {$first < 0} {\n"
3704 "return\n"
3705 "}\n"
3706 "set new [string index [$w get] [expr {$i-1}]][string index [$w get] $first]\n"
3707 "$w delete $first $i\n"
3708 "$w insert insert $new\n"
3709 "tkEntrySeeInsert $w\n"
3710 "}\n"
3711 "if {[string equal $tcl_platform(platform) \"windows\"]} {\n"
3712 "proc tkEntryNextWord {w start} {\n"
3713 "set pos [tcl_endOfWord [$w get] [$w index $start]]\n"
3714 "if {$pos >= 0} {\n"
3715 "set pos [tcl_startOfNextWord [$w get] $pos]\n"
3716 "}\n"
3717 "if {$pos < 0} {\n"
3718 "return end\n"
3719 "}\n"
3720 "return $pos\n"
3721 "}\n"
3722 "} else {\n"
3723 "proc tkEntryNextWord {w start} {\n"
3724 "set pos [tcl_endOfWord [$w get] [$w index $start]]\n"
3725 "if {$pos < 0} {\n"
3726 "return end\n"
3727 "}\n"
3728 "return $pos\n"
3729 "}\n"
3730 "}\n"
3731 "proc tkEntryPreviousWord {w start} {\n"
3732 "set pos [tcl_startOfPreviousWord [$w get] [$w index $start]]\n"
3733 "if {$pos < 0} {\n"
3734 "return 0\n"
3735 "}\n"
3736 "return $pos\n"
3737 "}\n"
3738 "proc tkEntryGetSelection {w} {\n"
3739 "set entryString [string range [$w get] [$w index sel.first] \\\n"
3740 "\011 [expr {[$w index sel.last] - 1}]]\n"
3741 "if {[string compare [$w cget -show] \"\"]} {\n"
3742 "regsub -all . $entryString [string index [$w cget -show] 0] entryString\n"
3743 "}\n"
3744 "return $entryString\n"
3745 "}\n"
3746 ;
3747 static char Et_zFile15[] =
3748 "proc tk_focusNext w {\n"
3749 "set cur $w\n"
3750 "while {1} {\n"
3751 "set parent $cur\n"
3752 "set children [winfo children $cur]\n"
3753 "set i -1\n"
3754 "while {1} {\n"
3755 "incr i\n"
3756 "if {$i < [llength $children]} {\n"
3757 "set cur [lindex $children $i]\n"
3758 "if {[string equal [winfo toplevel $cur] $cur]} {\n"
3759 "continue\n"
3760 "} else {\n"
3761 "break\n"
3762 "}\n"
3763 "}\n"
3764 "set cur $parent\n"
3765 "if {[string equal [winfo toplevel $cur] $cur]} {\n"
3766 "break\n"
3767 "}\n"
3768 "set parent [winfo parent $parent]\n"
3769 "set children [winfo children $parent]\n"
3770 "set i [lsearch -exact $children $cur]\n"
3771 "}\n"
3772 "if {[string equal $w $cur] || [tkFocusOK $cur]} {\n"
3773 "return $cur\n"
3774 "}\n"
3775 "}\n"
3776 "}\n"
3777 "proc tk_focusPrev w {\n"
3778 "set cur $w\n"
3779 "while {1} {\n"
3780 "if {[string equal [winfo toplevel $cur] $cur]} {\n"
3781 "set parent $cur\n"
3782 "set children [winfo children $cur]\n"
3783 "set i [llength $children]\n"
3784 "} else {\n"
3785 "set parent [winfo parent $cur]\n"
3786 "set children [winfo children $parent]\n"
3787 "set i [lsearch -exact $children $cur]\n"
3788 "}\n"
3789 "while {$i > 0} {\n"
3790 "incr i -1\n"
3791 "set cur [lindex $children $i]\n"
3792 "if {[string equal [winfo toplevel $cur] $cur]} {\n"
3793 "continue\n"
3794 "}\n"
3795 "set parent $cur\n"
3796 "set children [winfo children $parent]\n"
3797 "set i [llength $children]\n"
3798 "}\n"
3799 "set cur $parent\n"
3800 "if {[string equal $w $cur] || [tkFocusOK $cur]} {\n"
3801 "return $cur\n"
3802 "}\n"
3803 "}\n"
3804 "}\n"
3805 "proc tkFocusOK w {\n"
3806 "set code [catch {$w cget -takefocus} value]\n"
3807 "if {($code == 0) && [string compare $value \"\"]} {\n"
3808 "if {$value == 0} {\n"
3809 "return 0\n"
3810 "} elseif {$value == 1} {\n"
3811 "return [winfo viewable $w]\n"
3812 "} else {\n"
3813 "set value [uplevel #0 [list $value $w]]\n"
3814 "if {[string compare $value \"\"]} {\n"
3815 "return $value\n"
3816 "}\n"
3817 "}\n"
3818 "}\n"
3819 "if {![winfo viewable $w]} {\n"
3820 "return 0\n"
3821 "}\n"
3822 "set code [catch {$w cget -state} value]\n"
3823 "if {($code == 0) && [string equal $value \"disabled\"]} {\n"
3824 "return 0\n"
3825 "}\n"
3826 "regexp Key|Focus \"[bind $w] [bind [winfo class $w]]\"\n"
3827 "}\n"
3828 "proc tk_focusFollowsMouse {} {\n"
3829 "set old [bind all <Enter>]\n"
3830 "set script {\n"
3831 "if {[string equal \"%d\" \"NotifyAncestor\"] \\\n"
3832 "\011\011|| [string equal \"%d\" \"NotifyNonlinear\"] \\\n"
3833 "\011\011|| [string equal \"%d\" \"NotifyInferior\"]} {\n"
3834 "if {[tkFocusOK %W]} {\n"
3835 "focus %W\n"
3836 "}\n"
3837 "}\n"
3838 "}\n"
3839 "if {[string compare $old \"\"]} {\n"
3840 "bind all <Enter> \"$old; $script\"\n"
3841 "} else {\n"
3842 "bind all <Enter> $script\n"
3843 "}\n"
3844 "}\n"
3845 ;
3846 static char Et_zFile16[] =
3847 "bind Listbox <1> {\n"
3848 "if {[winfo exists %W]} {\n"
3849 "tkListboxBeginSelect %W [%W index @%x,%y]\n"
3850 "}\n"
3851 "}\n"
3852 "bind Listbox <Double-1> {\n"
3853 "}\n"
3854 "bind Listbox <B1-Motion> {\n"
3855 "set tkPriv(x) %x\n"
3856 "set tkPriv(y) %y\n"
3857 "tkListboxMotion %W [%W index @%x,%y]\n"
3858 "}\n"
3859 "bind Listbox <ButtonRelease-1> {\n"
3860 "tkCancelRepeat\n"
3861 "%W activate @%x,%y\n"
3862 "}\n"
3863 "bind Listbox <Shift-1> {\n"
3864 "tkListboxBeginExtend %W [%W index @%x,%y]\n"
3865 "}\n"
3866 "bind Listbox <Control-1> {\n"
3867 "tkListboxBeginToggle %W [%W index @%x,%y]\n"
3868 "}\n"
3869 "bind Listbox <B1-Leave> {\n"
3870 "set tkPriv(x) %x\n"
3871 "set tkPriv(y) %y\n"
3872 "tkListboxAutoScan %W\n"
3873 "}\n"
3874 "bind Listbox <B1-Enter> {\n"
3875 "tkCancelRepeat\n"
3876 "}\n"
3877 "bind Listbox <Up> {\n"
3878 "tkListboxUpDown %W -1\n"
3879 "}\n"
3880 "bind Listbox <Shift-Up> {\n"
3881 "tkListboxExtendUpDown %W -1\n"
3882 "}\n"
3883 "bind Listbox <Down> {\n"
3884 "tkListboxUpDown %W 1\n"
3885 "}\n"
3886 "bind Listbox <Shift-Down> {\n"
3887 "tkListboxExtendUpDown %W 1\n"
3888 "}\n"
3889 "bind Listbox <Left> {\n"
3890 "%W xview scroll -1 units\n"
3891 "}\n"
3892 "bind Listbox <Control-Left> {\n"
3893 "%W xview scroll -1 pages\n"
3894 "}\n"
3895 "bind Listbox <Right> {\n"
3896 "%W xview scroll 1 units\n"
3897 "}\n"
3898 "bind Listbox <Control-Right> {\n"
3899 "%W xview scroll 1 pages\n"
3900 "}\n"
3901 "bind Listbox <Prior> {\n"
3902 "%W yview scroll -1 pages\n"
3903 "%W activate @0,0\n"
3904 "}\n"
3905 "bind Listbox <Next> {\n"
3906 "%W yview scroll 1 pages\n"
3907 "%W activate @0,0\n"
3908 "}\n"
3909 "bind Listbox <Control-Prior> {\n"
3910 "%W xview scroll -1 pages\n"
3911 "}\n"
3912 "bind Listbox <Control-Next> {\n"
3913 "%W xview scroll 1 pages\n"
3914 "}\n"
3915 "bind Listbox <Home> {\n"
3916 "%W xview moveto 0\n"
3917 "}\n"
3918 "bind Listbox <End> {\n"
3919 "%W xview moveto 1\n"
3920 "}\n"
3921 "bind Listbox <Control-Home> {\n"
3922 "%W activate 0\n"
3923 "%W see 0\n"
3924 "%W selection clear 0 end\n"
3925 "%W selection set 0\n"
3926 "event generate %W <<ListboxSelect>>\n"
3927 "}\n"
3928 "bind Listbox <Shift-Control-Home> {\n"
3929 "tkListboxDataExtend %W 0\n"
3930 "}\n"
3931 "bind Listbox <Control-End> {\n"
3932 "%W activate end\n"
3933 "%W see end\n"
3934 "%W selection clear 0 end\n"
3935 "%W selection set end\n"
3936 "event generate %W <<ListboxSelect>>\n"
3937 "}\n"
3938 "bind Listbox <Shift-Control-End> {\n"
3939 "tkListboxDataExtend %W [%W index end]\n"
3940 "}\n"
3941 "bind Listbox <<Copy>> {\n"
3942 "if {[string equal [selection own -displayof %W] \"%W\"]} {\n"
3943 "clipboard clear -displayof %W\n"
3944 "clipboard append -displayof %W [selection get -displayof %W]\n"
3945 "}\n"
3946 "}\n"
3947 "bind Listbox <space> {\n"
3948 "tkListboxBeginSelect %W [%W index active]\n"
3949 "}\n"
3950 "bind Listbox <Select> {\n"
3951 "tkListboxBeginSelect %W [%W index active]\n"
3952 "}\n"
3953 "bind Listbox <Control-Shift-space> {\n"
3954 "tkListboxBeginExtend %W [%W index active]\n"
3955 "}\n"
3956 "bind Listbox <Shift-Select> {\n"
3957 "tkListboxBeginExtend %W [%W index active]\n"
3958 "}\n"
3959 "bind Listbox <Escape> {\n"
3960 "tkListboxCancel %W\n"
3961 "}\n"
3962 "bind Listbox <Control-slash> {\n"
3963 "tkListboxSelectAll %W\n"
3964 "}\n"
3965 "bind Listbox <Control-backslash> {\n"
3966 "if {[string compare [%W cget -selectmode] \"browse\"]} {\n"
3967 "%W selection clear 0 end\n"
3968 "event generate %W <<ListboxSelect>>\n"
3969 "}\n"
3970 "}\n"
3971 "bind Listbox <2> {\n"
3972 "%W scan mark %x %y\n"
3973 "}\n"
3974 "bind Listbox <B2-Motion> {\n"
3975 "%W scan dragto %x %y\n"
3976 "}\n"
3977 "bind Listbox <MouseWheel> {\n"
3978 "%W yview scroll [expr {- (%D / 120) * 4}] units\n"
3979 "}\n"
3980 "if {[string equal \"unix\" $tcl_platform(platform)]} {\n"
3981 "bind Listbox <4> {\n"
3982 "if {!$tk_strictMotif} {\n"
3983 "%W yview scroll -5 units\n"
3984 "}\n"
3985 "}\n"
3986 "bind Listbox <5> {\n"
3987 "if {!$tk_strictMotif} {\n"
3988 "%W yview scroll 5 units\n"
3989 "}\n"
3990 "}\n"
3991 "}\n"
3992 "proc tkListboxBeginSelect {w el} {\n"
3993 "global tkPriv\n"
3994 "if {[string equal [$w cget -selectmode] \"multiple\"]} {\n"
3995 "if {[$w selection includes $el]} {\n"
3996 "$w selection clear $el\n"
3997 "} else {\n"
3998 "$w selection set $el\n"
3999 "}\n"
4000 "} else {\n"
4001 "$w selection clear 0 end\n"
4002 "$w selection set $el\n"
4003 "$w selection anchor $el\n"
4004 "set tkPriv(listboxSelection) {}\n"
4005 "set tkPriv(listboxPrev) $el\n"
4006 "}\n"
4007 "event generate $w <<ListboxSelect>>\n"
4008 "}\n"
4009 "proc tkListboxMotion {w el} {\n"
4010 "global tkPriv\n"
4011 "if {$el == $tkPriv(listboxPrev)} {\n"
4012 "return\n"
4013 "}\n"
4014 "set anchor [$w index anchor]\n"
4015 "switch [$w cget -selectmode] {\n"
4016 "browse {\n"
4017 "$w selection clear 0 end\n"
4018 "$w selection set $el\n"
4019 "set tkPriv(listboxPrev) $el\n"
4020 "event generate $w <<ListboxSelect>>\n"
4021 "}\n"
4022 "extended {\n"
4023 "set i $tkPriv(listboxPrev)\n"
4024 "if {[string equal {} $i]} {\n"
4025 "set i $el\n"
4026 "$w selection set $el\n"
4027 "}\n"
4028 "if {[$w selection includes anchor]} {\n"
4029 "$w selection clear $i $el\n"
4030 "$w selection set anchor $el\n"
4031 "} else {\n"
4032 "$w selection clear $i $el\n"
4033 "$w selection clear anchor $el\n"
4034 "}\n"
4035 "if {![info exists tkPriv(listboxSelection)]} {\n"
4036 "set tkPriv(listboxSelection) [$w curselection]\n"
4037 "}\n"
4038 "while {($i < $el) && ($i < $anchor)} {\n"
4039 "if {[lsearch $tkPriv(listboxSelection) $i] >= 0} {\n"
4040 "$w selection set $i\n"
4041 "}\n"
4042 "incr i\n"
4043 "}\n"
4044 "while {($i > $el) && ($i > $anchor)} {\n"
4045 "if {[lsearch $tkPriv(listboxSelection) $i] >= 0} {\n"
4046 "$w selection set $i\n"
4047 "}\n"
4048 "incr i -1\n"
4049 "}\n"
4050 "set tkPriv(listboxPrev) $el\n"
4051 "event generate $w <<ListboxSelect>>\n"
4052 "}\n"
4053 "}\n"
4054 "}\n"
4055 "proc tkListboxBeginExtend {w el} {\n"
4056 "if {[string equal [$w cget -selectmode] \"extended\"]} {\n"
4057 "if {[$w selection includes anchor]} {\n"
4058 "tkListboxMotion $w $el\n"
4059 "} else {\n"
4060 "tkListboxBeginSelect $w $el\n"
4061 "}\n"
4062 "}\n"
4063 "}\n"
4064 "proc tkListboxBeginToggle {w el} {\n"
4065 "global tkPriv\n"
4066 "if {[string equal [$w cget -selectmode] \"extended\"]} {\n"
4067 "set tkPriv(listboxSelection) [$w curselection]\n"
4068 "set tkPriv(listboxPrev) $el\n"
4069 "$w selection anchor $el\n"
4070 "if {[$w selection includes $el]} {\n"
4071 "$w selection clear $el\n"
4072 "} else {\n"
4073 "$w selection set $el\n"
4074 "}\n"
4075 "event generate $w <<ListboxSelect>>\n"
4076 "}\n"
4077 "}\n"
4078 "proc tkListboxAutoScan {w} {\n"
4079 "global tkPriv\n"
4080 "if {![winfo exists $w]} return\n"
4081 "set x $tkPriv(x)\n"
4082 "set y $tkPriv(y)\n"
4083 "if {$y >= [winfo height $w]} {\n"
4084 "$w yview scroll 1 units\n"
4085 "} elseif {$y < 0} {\n"
4086 "$w yview scroll -1 units\n"
4087 "} elseif {$x >= [winfo width $w]} {\n"
4088 "$w xview scroll 2 units\n"
4089 "} elseif {$x < 0} {\n"
4090 "$w xview scroll -2 units\n"
4091 "} else {\n"
4092 "return\n"
4093 "}\n"
4094 "tkListboxMotion $w [$w index @$x,$y]\n"
4095 "set tkPriv(afterId) [after 50 [list tkListboxAutoScan $w]]\n"
4096 "}\n"
4097 "proc tkListboxUpDown {w amount} {\n"
4098 "global tkPriv\n"
4099 "$w activate [expr {[$w index active] + $amount}]\n"
4100 "$w see active\n"
4101 "switch [$w cget -selectmode] {\n"
4102 "browse {\n"
4103 "$w selection clear 0 end\n"
4104 "$w selection set active\n"
4105 "event generate $w <<ListboxSelect>>\n"
4106 "}\n"
4107 "extended {\n"
4108 "$w selection clear 0 end\n"
4109 "$w selection set active\n"
4110 "$w selection anchor active\n"
4111 "set tkPriv(listboxPrev) [$w index active]\n"
4112 "set tkPriv(listboxSelection) {}\n"
4113 "event generate $w <<ListboxSelect>>\n"
4114 "}\n"
4115 "}\n"
4116 "}\n"
4117 "proc tkListboxExtendUpDown {w amount} {\n"
4118 "if {[string compare [$w cget -selectmode] \"extended\"]} {\n"
4119 "return\n"
4120 "}\n"
4121 "set active [$w index active]\n"
4122 "if {![info exists tkPriv(listboxSelection)]} {\n"
4123 "global tkPriv\n"
4124 "$w selection set $active\n"
4125 "set tkPriv(listboxSelection) [$w curselection]\n"
4126 "}\n"
4127 "$w activate [expr {$active + $amount}]\n"
4128 "$w see active\n"
4129 "tkListboxMotion $w [$w index active]\n"
4130 "}\n"
4131 "proc tkListboxDataExtend {w el} {\n"
4132 "set mode [$w cget -selectmode]\n"
4133 "if {[string equal $mode \"extended\"]} {\n"
4134 "$w activate $el\n"
4135 "$w see $el\n"
4136 "if {[$w selection includes anchor]} {\n"
4137 "tkListboxMotion $w $el\n"
4138 "}\n"
4139 "} elseif {[string equal $mode \"multiple\"]} {\n"
4140 "$w activate $el\n"
4141 "$w see $el\n"
4142 "}\n"
4143 "}\n"
4144 "proc tkListboxCancel w {\n"
4145 "global tkPriv\n"
4146 "if {[string compare [$w cget -selectmode] \"extended\"]} {\n"
4147 "return\n"
4148 "}\n"
4149 "set first [$w index anchor]\n"
4150 "set last $tkPriv(listboxPrev)\n"
4151 "if { [string equal $last \"\"] } {\n"
4152 "return\n"
4153 "}\n"
4154 "if {$first > $last} {\n"
4155 "set tmp $first\n"
4156 "set first $last\n"
4157 "set last $tmp\n"
4158 "}\n"
4159 "$w selection clear $first $last\n"
4160 "while {$first <= $last} {\n"
4161 "if {[lsearch $tkPriv(listboxSelection) $first] >= 0} {\n"
4162 "$w selection set $first\n"
4163 "}\n"
4164 "incr first\n"
4165 "}\n"
4166 "event generate $w <<ListboxSelect>>\n"
4167 "}\n"
4168 "proc tkListboxSelectAll w {\n"
4169 "set mode [$w cget -selectmode]\n"
4170 "if {[string equal $mode \"single\"] || [string equal $mode \"browse\"]} {\n"
4171 "$w selection clear 0 end\n"
4172 "$w selection set active\n"
4173 "} else {\n"
4174 "$w selection set 0 end\n"
4175 "}\n"
4176 "event generate $w <<ListboxSelect>>\n"
4177 "}\n"
4178 ;
4179 static char Et_zFile17[] =
4180 "bind Menubutton <FocusIn> {}\n"
4181 "bind Menubutton <Enter> {\n"
4182 "tkMbEnter %W\n"
4183 "}\n"
4184 "bind Menubutton <Leave> {\n"
4185 "tkMbLeave %W\n"
4186 "}\n"
4187 "bind Menubutton <1> {\n"
4188 "if {[string compare $tkPriv(inMenubutton) \"\"]} {\n"
4189 "tkMbPost $tkPriv(inMenubutton) %X %Y\n"
4190 "}\n"
4191 "}\n"
4192 "bind Menubutton <Motion> {\n"
4193 "tkMbMotion %W up %X %Y\n"
4194 "}\n"
4195 "bind Menubutton <B1-Motion> {\n"
4196 "tkMbMotion %W down %X %Y\n"
4197 "}\n"
4198 "bind Menubutton <ButtonRelease-1> {\n"
4199 "tkMbButtonUp %W\n"
4200 "}\n"
4201 "bind Menubutton <space> {\n"
4202 "tkMbPost %W\n"
4203 "tkMenuFirstEntry [%W cget -menu]\n"
4204 "}\n"
4205 "bind Menu <FocusIn> {}\n"
4206 "bind Menu <Enter> {\n"
4207 "set tkPriv(window) %W\n"
4208 "if {[string equal [%W cget -type] \"tearoff\"]} {\n"
4209 "if {[string compare \"%m\" \"NotifyUngrab\"]} {\n"
4210 "if {[string equal $tcl_platform(platform) \"unix\"]} {\n"
4211 "tk_menuSetFocus %W\n"
4212 "}\n"
4213 "}\n"
4214 "}\n"
4215 "tkMenuMotion %W %x %y %s\n"
4216 "}\n"
4217 "bind Menu <Leave> {\n"
4218 "tkMenuLeave %W %X %Y %s\n"
4219 "}\n"
4220 "bind Menu <Motion> {\n"
4221 "tkMenuMotion %W %x %y %s\n"
4222 "}\n"
4223 "bind Menu <ButtonPress> {\n"
4224 "tkMenuButtonDown %W\n"
4225 "}\n"
4226 "bind Menu <ButtonRelease> {\n"
4227 "tkMenuInvoke %W 1\n"
4228 "}\n"
4229 "bind Menu <space> {\n"
4230 "tkMenuInvoke %W 0\n"
4231 "}\n"
4232 "bind Menu <Return> {\n"
4233 "tkMenuInvoke %W 0\n"
4234 "}\n"
4235 "bind Menu <Escape> {\n"
4236 "tkMenuEscape %W\n"
4237 "}\n"
4238 "bind Menu <Left> {\n"
4239 "tkMenuLeftArrow %W\n"
4240 "}\n"
4241 "bind Menu <Right> {\n"
4242 "tkMenuRightArrow %W\n"
4243 "}\n"
4244 "bind Menu <Up> {\n"
4245 "tkMenuUpArrow %W\n"
4246 "}\n"
4247 "bind Menu <Down> {\n"
4248 "tkMenuDownArrow %W\n"
4249 "}\n"
4250 "bind Menu <KeyPress> {\n"
4251 "tkTraverseWithinMenu %W %A\n"
4252 "}\n"
4253 "if {[string equal $tcl_platform(platform) \"unix\"]} {\n"
4254 "bind all <Alt-KeyPress> {\n"
4255 "tkTraverseToMenu %W %A\n"
4256 "}\n"
4257 "bind all <F10> {\n"
4258 "tkFirstMenu %W\n"
4259 "}\n"
4260 "} else {\n"
4261 "bind Menubutton <Alt-KeyPress> {\n"
4262 "tkTraverseToMenu %W %A\n"
4263 "}\n"
4264 "bind Menubutton <F10> {\n"
4265 "tkFirstMenu %W\n"
4266 "}\n"
4267 "}\n"
4268 "proc tkMbEnter w {\n"
4269 "global tkPriv\n"
4270 "if {[string compare $tkPriv(inMenubutton) \"\"]} {\n"
4271 "tkMbLeave $tkPriv(inMenubutton)\n"
4272 "}\n"
4273 "set tkPriv(inMenubutton) $w\n"
4274 "if {[string compare [$w cget -state] \"disabled\"]} {\n"
4275 "$w configure -state active\n"
4276 "}\n"
4277 "}\n"
4278 "proc tkMbLeave w {\n"
4279 "global tkPriv\n"
4280 "set tkPriv(inMenubutton) {}\n"
4281 "if {![winfo exists $w]} {\n"
4282 "return\n"
4283 "}\n"
4284 "if {[string equal [$w cget -state] \"active\"]} {\n"
4285 "$w configure -state normal\n"
4286 "}\n"
4287 "}\n"
4288 "proc tkMbPost {w {x {}} {y {}}} {\n"
4289 "global tkPriv errorInfo\n"
4290 "global tcl_platform\n"
4291 "if {[string equal [$w cget -state] \"disabled\"] || \\\n"
4292 "\011 [string equal $w $tkPriv(postedMb)]} {\n"
4293 "return\n"
4294 "}\n"
4295 "set menu [$w cget -menu]\n"
4296 "if {[string equal $menu \"\"]} {\n"
4297 "return\n"
4298 "}\n"
4299 "set tearoff [expr {[string equal $tcl_platform(platform) \"unix\"] \\\n"
4300 "\011 || [string equal [$menu cget -type] \"tearoff\"]}]\n"
4301 "if {[string first $w $menu] != 0} {\n"
4302 "error \"can't post $menu: it isn't a descendant of $w (this is a new requirement in Tk versions 3.0 and later)\"\n"
4303 "}\n"
4304 "set cur $tkPriv(postedMb)\n"
4305 "if {[string compare $cur \"\"]} {\n"
4306 "tkMenuUnpost {}\n"
4307 "}\n"
4308 "set tkPriv(cursor) [$w cget -cursor]\n"
4309 "set tkPriv(relief) [$w cget -relief]\n"
4310 "$w configure -cursor arrow\n"
4311 "$w configure -relief raised\n"
4312 "set tkPriv(postedMb) $w\n"
4313 "set tkPriv(focus) [focus]\n"
4314 "$menu activate none\n"
4315 "tkGenerateMenuSelect $menu\n"
4316 "update idletasks\n"
4317 "if {[catch {\n"
4318 "switch [$w cget -direction] {\n"
4319 "above {\n"
4320 "set x [winfo rootx $w]\n"
4321 "set y [expr {[winfo rooty $w] - [winfo reqheight $menu]}]\n"
4322 "$menu post $x $y\n"
4323 "}\n"
4324 "below {\n"
4325 "set x [winfo rootx $w]\n"
4326 "set y [expr {[winfo rooty $w] + [winfo height $w]}]\n"
4327 "$menu post $x $y\n"
4328 "}\n"
4329 "left {\n"
4330 "set x [expr {[winfo rootx $w] - [winfo reqwidth $menu]}]\n"
4331 "set y [expr {(2 * [winfo rooty $w] + [winfo height $w]) / 2}]\n"
4332 "set entry [tkMenuFindName $menu [$w cget -text]]\n"
4333 "if {[$w cget -indicatoron]} {\n"
4334 "if {$entry == [$menu index last]} {\n"
4335 "incr y [expr {-([$menu yposition $entry] \\\n"
4336 "\011\011\011 \011+ [winfo reqheight $menu])/2}]\n"
4337 "} else {\n"
4338 "incr y [expr {-([$menu yposition $entry] \\\n"
4339 "\011\011\011 + [$menu yposition [expr {$entry+1}]])/2}]\n"
4340 "}\n"
4341 "}\n"
4342 "$menu post $x $y\n"
4343 "if {[string compare $entry {}] && [string compare [$menu entrycget $entry -state] \"disabled\"]} {\n"
4344 "$menu activate $entry\n"
4345 "tkGenerateMenuSelect $menu\n"
4346 "}\n"
4347 "}\n"
4348 "right {\n"
4349 "set x [expr {[winfo rootx $w] + [winfo width $w]}]\n"
4350 "set y [expr {(2 * [winfo rooty $w] + [winfo height $w]) / 2}]\n"
4351 "set entry [tkMenuFindName $menu [$w cget -text]]\n"
4352 "if {[$w cget -indicatoron]} {\n"
4353 "if {$entry == [$menu index last]} {\n"
4354 "incr y [expr {-([$menu yposition $entry] \\\n"
4355 "\011\011\011 \011+ [winfo reqheight $menu])/2}]\n"
4356 "} else {\n"
4357 "incr y [expr {-([$menu yposition $entry] \\\n"
4358 "\011\011\011 + [$menu yposition [expr {$entry+1}]])/2}]\n"
4359 "}\n"
4360 "}\n"
4361 "$menu post $x $y\n"
4362 "if {[string compare $entry {}] && [string compare [$menu entrycget $entry -state] \"disabled\"]} {\n"
4363 "$menu activate $entry\n"
4364 "tkGenerateMenuSelect $menu\n"
4365 "}\n"
4366 "}\n"
4367 "default {\n"
4368 "if {[$w cget -indicatoron]} {\n"
4369 "if {[string equal $y {}]} {\n"
4370 "set x [expr {[winfo rootx $w] + [winfo width $w]/2}]\n"
4371 "set y [expr {[winfo rooty $w] + [winfo height $w]/2}]\n"
4372 "}\n"
4373 "tkPostOverPoint $menu $x $y [tkMenuFindName $menu [$w cget -text]]\n"
4374 "} else {\n"
4375 "$menu post [winfo rootx $w] [expr {[winfo rooty $w]+[winfo height $w]}]\n"
4376 "} \n"
4377 "}\n"
4378 "}\n"
4379 "} msg]} {\n"
4380 "set savedInfo $errorInfo\n"
4381 "tkMenuUnpost {}\n"
4382 "error $msg $savedInfo\n"
4383 "}\n"
4384 "set tkPriv(tearoff) $tearoff\n"
4385 "if {$tearoff != 0} {\n"
4386 "focus $menu\n"
4387 "if {[winfo viewable $w]} {\n"
4388 "tkSaveGrabInfo $w\n"
4389 "grab -global $w\n"
4390 "}\n"
4391 "}\n"
4392 "}\n"
4393 "proc tkMenuUnpost menu {\n"
4394 "global tcl_platform\n"
4395 "global tkPriv\n"
4396 "set mb $tkPriv(postedMb)\n"
4397 "catch {focus $tkPriv(focus)}\n"
4398 "set tkPriv(focus) \"\"\n"
4399 "catch {\n"
4400 "if {[string compare $mb \"\"]} {\n"
4401 "set menu [$mb cget -menu]\n"
4402 "$menu unpost\n"
4403 "set tkPriv(postedMb) {}\n"
4404 "$mb configure -cursor $tkPriv(cursor)\n"
4405 "$mb configure -relief $tkPriv(relief)\n"
4406 "} elseif {[string compare $tkPriv(popup) \"\"]} {\n"
4407 "$tkPriv(popup) unpost\n"
4408 "set tkPriv(popup) {}\n"
4409 "} elseif {[string compare [$menu cget -type] \"menubar\"] \\\n"
4410 "\011\011&& [string compare [$menu cget -type] \"tearoff\"]} {\n"
4411 "while {1} {\n"
4412 "set parent [winfo parent $menu]\n"
4413 "if {[string compare [winfo class $parent] \"Menu\"] \\\n"
4414 "\011\011\011|| ![winfo ismapped $parent]} {\n"
4415 "break\n"
4416 "}\n"
4417 "$parent activate none\n"
4418 "$parent postcascade none\n"
4419 "tkGenerateMenuSelect $parent\n"
4420 "set type [$parent cget -type]\n"
4421 "if {[string equal $type \"menubar\"] || \\\n"
4422 "\011\011\011[string equal $type \"tearoff\"]} {\n"
4423 "break\n"
4424 "}\n"
4425 "set menu $parent\n"
4426 "}\n"
4427 "if {[string compare [$menu cget -type] \"menubar\"]} {\n"
4428 "$menu unpost\n"
4429 "}\n"
4430 "}\n"
4431 "}\n"
4432 "if {($tkPriv(tearoff) != 0) || [string compare $tkPriv(menuBar) \"\"]} {\n"
4433 "if {[string compare $menu \"\"]} {\n"
4434 "set grab [grab current $menu]\n"
4435 "if {[string compare $grab \"\"]} {\n"
4436 "grab release $grab\n"
4437 "}\n"
4438 "}\n"
4439 "tkRestoreOldGrab\n"
4440 "if {[string compare $tkPriv(menuBar) \"\"]} {\n"
4441 "$tkPriv(menuBar) configure -cursor $tkPriv(cursor)\n"
4442 "set tkPriv(menuBar) {}\n"
4443 "}\n"
4444 "if {[string compare $tcl_platform(platform) \"unix\"]} {\n"
4445 "set tkPriv(tearoff) 0\n"
4446 "}\n"
4447 "}\n"
4448 "}\n"
4449 "proc tkMbMotion {w upDown rootx rooty} {\n"
4450 "global tkPriv\n"
4451 "if {[string equal $tkPriv(inMenubutton) $w]} {\n"
4452 "return\n"
4453 "}\n"
4454 "set new [winfo containing $rootx $rooty]\n"
4455 "if {[string compare $new $tkPriv(inMenubutton)] \\\n"
4456 "\011 && ([string equal $new \"\"] \\\n"
4457 "\011 || [string equal [winfo toplevel $new] [winfo toplevel $w]])} {\n"
4458 "if {[string compare $tkPriv(inMenubutton) \"\"]} {\n"
4459 "tkMbLeave $tkPriv(inMenubutton)\n"
4460 "}\n"
4461 "if {[string compare $new \"\"] \\\n"
4462 "\011\011&& [string equal [winfo class $new] \"Menubutton\"] \\\n"
4463 "\011\011&& ([$new cget -indicatoron] == 0) \\\n"
4464 "\011\011&& ([$w cget -indicatoron] == 0)} {\n"
4465 "if {[string equal $upDown \"down\"]} {\n"
4466 "tkMbPost $new $rootx $rooty\n"
4467 "} else {\n"
4468 "tkMbEnter $new\n"
4469 "}\n"
4470 "}\n"
4471 "}\n"
4472 "}\n"
4473 "proc tkMbButtonUp w {\n"
4474 "global tkPriv\n"
4475 "global tcl_platform\n"
4476 "set menu [$w cget -menu]\n"
4477 "set tearoff [expr {[string equal $tcl_platform(platform) \"unix\"] || \\\n"
4478 "\011 ([string compare $menu {}] && \\\n"
4479 "\011 [string equal [$menu cget -type] \"tearoff\"])}]\n"
4480 "if {($tearoff != 0) && [string equal $tkPriv(postedMb) $w] \\\n"
4481 "\011 && [string equal $tkPriv(inMenubutton) $w]} {\n"
4482 "tkMenuFirstEntry [$tkPriv(postedMb) cget -menu]\n"
4483 "} else {\n"
4484 "tkMenuUnpost {}\n"
4485 "}\n"
4486 "}\n"
4487 "proc tkMenuMotion {menu x y state} {\n"
4488 "global tkPriv\n"
4489 "if {[string equal $menu $tkPriv(window)]} {\n"
4490 "if {[string equal [$menu cget -type] \"menubar\"]} {\n"
4491 "if {[info exists tkPriv(focus)] && \\\n"
4492 "\011\011 [string compare $menu $tkPriv(focus)]} {\n"
4493 "$menu activate @$x,$y\n"
4494 "tkGenerateMenuSelect $menu\n"
4495 "}\n"
4496 "} else {\n"
4497 "$menu activate @$x,$y\n"
4498 "tkGenerateMenuSelect $menu\n"
4499 "}\n"
4500 "}\n"
4501 "if {($state & 0x1f00) != 0} {\n"
4502 "$menu postcascade active\n"
4503 "}\n"
4504 "}\n"
4505 "proc tkMenuButtonDown menu {\n"
4506 "global tkPriv\n"
4507 "global tcl_platform\n"
4508 "if {![winfo viewable $menu]} {\n"
4509 "return\n"
4510 "}\n"
4511 "$menu postcascade active\n"
4512 "if {[string compare $tkPriv(postedMb) \"\"] && \\\n"
4513 "\011 [winfo viewable $tkPriv(postedMb)]} {\n"
4514 "grab -global $tkPriv(postedMb)\n"
4515 "} else {\n"
4516 "while {[string equal [$menu cget -type] \"normal\"] \\\n"
4517 "\011\011&& [string equal [winfo class [winfo parent $menu]] \"Menu\"] \\\n"
4518 "\011\011&& [winfo ismapped [winfo parent $menu]]} {\n"
4519 "set menu [winfo parent $menu]\n"
4520 "}\n"
4521 "if {[string equal $tkPriv(menuBar) {}]} {\n"
4522 "set tkPriv(menuBar) $menu\n"
4523 "set tkPriv(cursor) [$menu cget -cursor]\n"
4524 "$menu configure -cursor arrow\n"
4525 "}\n"
4526 "if {[string compare $menu [grab current $menu]]} {\n"
4527 "tkSaveGrabInfo $menu\n"
4528 "}\n"
4529 "if {[string equal $tcl_platform(platform) \"unix\"]} {\n"
4530 "grab -global $menu\n"
4531 "}\n"
4532 "}\n"
4533 "}\n"
4534 "proc tkMenuLeave {menu rootx rooty state} {\n"
4535 "global tkPriv\n"
4536 "set tkPriv(window) {}\n"
4537 "if {[string equal [$menu index active] \"none\"]} {\n"
4538 "return\n"
4539 "}\n"
4540 "if {[string equal [$menu type active] \"cascade\"]\n"
4541 "&& [string equal [winfo containing $rootx $rooty] \\\n"
4542 " [$menu entrycget active -menu]]} {\n"
4543 "return\n"
4544 "}\n"
4545 "$menu activate none\n"
4546 "tkGenerateMenuSelect $menu\n"
4547 "}\n"
4548 "proc tkMenuInvoke {w buttonRelease} {\n"
4549 "global tkPriv\n"
4550 "if {$buttonRelease && [string equal $tkPriv(window) {}]} {\n"
4551 "$w postcascade none\n"
4552 "$w activate none\n"
4553 "event generate $w <<MenuSelect>>\n"
4554 "tkMenuUnpost $w\n"
4555 "return\n"
4556 "}\n"
4557 "if {[string equal [$w type active] \"cascade\"]} {\n"
4558 "$w postcascade active\n"
4559 "set menu [$w entrycget active -menu]\n"
4560 "tkMenuFirstEntry $menu\n"
4561 "} elseif {[string equal [$w type active] \"tearoff\"]} {\n"
4562 "tkTearOffMenu $w\n"
4563 "tkMenuUnpost $w\n"
4564 "} elseif {[string equal [$w cget -type] \"menubar\"]} {\n"
4565 "$w postcascade none\n"
4566 "set active [$w index active]\n"
4567 "set isCascade [string equal [$w type $active] \"cascade\"]\n"
4568 "if { $isCascade } {\n"
4569 "$w activate none\n"
4570 "event generate $w <<MenuSelect>>\n"
4571 "}\n"
4572 "tkMenuUnpost $w\n"
4573 "if { !$isCascade } {\n"
4574 "uplevel #0 [list $w invoke $active]\n"
4575 "}\n"
4576 "} else {\n"
4577 "tkMenuUnpost $w\n"
4578 "uplevel #0 [list $w invoke active]\n"
4579 "}\n"
4580 "}\n"
4581 "proc tkMenuEscape menu {\n"
4582 "set parent [winfo parent $menu]\n"
4583 "if {[string compare [winfo class $parent] \"Menu\"]} {\n"
4584 "tkMenuUnpost $menu\n"
4585 "} elseif {[string equal [$parent cget -type] \"menubar\"]} {\n"
4586 "tkMenuUnpost $menu\n"
4587 "tkRestoreOldGrab\n"
4588 "} else {\n"
4589 "tkMenuNextMenu $menu left\n"
4590 "}\n"
4591 "}\n"
4592 "proc tkMenuUpArrow {menu} {\n"
4593 "if {[string equal [$menu cget -type] \"menubar\"]} {\n"
4594 "tkMenuNextMenu $menu left\n"
4595 "} else {\n"
4596 "tkMenuNextEntry $menu -1\n"
4597 "}\n"
4598 "}\n"
4599 "proc tkMenuDownArrow {menu} {\n"
4600 "if {[string equal [$menu cget -type] \"menubar\"]} {\n"
4601 "tkMenuNextMenu $menu right\n"
4602 "} else {\n"
4603 "tkMenuNextEntry $menu 1\n"
4604 "}\n"
4605 "}\n"
4606 "proc tkMenuLeftArrow {menu} {\n"
4607 "if {[string equal [$menu cget -type] \"menubar\"]} {\n"
4608 "tkMenuNextEntry $menu -1\n"
4609 "} else {\n"
4610 "tkMenuNextMenu $menu left\n"
4611 "}\n"
4612 "}\n"
4613 "proc tkMenuRightArrow {menu} {\n"
4614 "if {[string equal [$menu cget -type] \"menubar\"]} {\n"
4615 "tkMenuNextEntry $menu 1\n"
4616 "} else {\n"
4617 "tkMenuNextMenu $menu right\n"
4618 "}\n"
4619 "}\n"
4620 "proc tkMenuNextMenu {menu direction} {\n"
4621 "global tkPriv\n"
4622 "if {[string equal $direction \"right\"]} {\n"
4623 "set count 1\n"
4624 "set parent [winfo parent $menu]\n"
4625 "set class [winfo class $parent]\n"
4626 "if {[string equal [$menu type active] \"cascade\"]} {\n"
4627 "$menu postcascade active\n"
4628 "set m2 [$menu entrycget active -menu]\n"
4629 "if {[string compare $m2 \"\"]} {\n"
4630 "tkMenuFirstEntry $m2\n"
4631 "}\n"
4632 "return\n"
4633 "} else {\n"
4634 "set parent [winfo parent $menu]\n"
4635 "while {[string compare $parent \".\"]} {\n"
4636 "if {[string equal [winfo class $parent] \"Menu\"] \\\n"
4637 "\011\011\011&& [string equal [$parent cget -type] \"menubar\"]} {\n"
4638 "tk_menuSetFocus $parent\n"
4639 "tkMenuNextEntry $parent 1\n"
4640 "return\n"
4641 "}\n"
4642 "set parent [winfo parent $parent]\n"
4643 "}\n"
4644 "}\n"
4645 "} else {\n"
4646 "set count -1\n"
4647 "set m2 [winfo parent $menu]\n"
4648 "if {[string equal [winfo class $m2] \"Menu\"]} {\n"
4649 "if {[string compare [$m2 cget -type] \"menubar\"]} {\n"
4650 "$menu activate none\n"
4651 "tkGenerateMenuSelect $menu\n"
4652 "tk_menuSetFocus $m2\n"
4653 "set tmp [$m2 index active]\n"
4654 "$m2 activate none\n"
4655 "$m2 activate $tmp\n"
4656 "return\n"
4657 "}\n"
4658 "}\n"
4659 "}\n"
4660 "set m2 [winfo parent $menu]\n"
4661 "if {[string equal [winfo class $m2] \"Menu\"]} {\n"
4662 "if {[string equal [$m2 cget -type] \"menubar\"]} {\n"
4663 "tk_menuSetFocus $m2\n"
4664 "tkMenuNextEntry $m2 -1\n"
4665 "return\n"
4666 "}\n"
4667 "}\n"
4668 "set w $tkPriv(postedMb)\n"
4669 "if {[string equal $w \"\"]} {\n"
4670 "return\n"
4671 "}\n"
4672 "set buttons [winfo children [winfo parent $w]]\n"
4673 "set length [llength $buttons]\n"
4674 "set i [expr {[lsearch -exact $buttons $w] + $count}]\n"
4675 "while {1} {\n"
4676 "while {$i < 0} {\n"
4677 "incr i $length\n"
4678 "}\n"
4679 "while {$i >= $length} {\n"
4680 "incr i -$length\n"
4681 "}\n"
4682 "set mb [lindex $buttons $i]\n"
4683 "if {[string equal [winfo class $mb] \"Menubutton\"] \\\n"
4684 "\011\011&& [string compare [$mb cget -state] \"disabled\"] \\\n"
4685 "\011\011&& [string compare [$mb cget -menu] \"\"] \\\n"
4686 "\011\011&& [string compare [[$mb cget -menu] index last] \"none\"]} {\n"
4687 "break\n"
4688 "}\n"
4689 "if {[string equal $mb $w]} {\n"
4690 "return\n"
4691 "}\n"
4692 "incr i $count\n"
4693 "}\n"
4694 "tkMbPost $mb\n"
4695 "tkMenuFirstEntry [$mb cget -menu]\n"
4696 "}\n"
4697 "proc tkMenuNextEntry {menu count} {\n"
4698 "global tkPriv\n"
4699 "if {[string equal [$menu index last] \"none\"]} {\n"
4700 "return\n"
4701 "}\n"
4702 "set length [expr {[$menu index last]+1}]\n"
4703 "set quitAfter $length\n"
4704 "set active [$menu index active]\n"
4705 "if {[string equal $active \"none\"]} {\n"
4706 "set i 0\n"
4707 "} else {\n"
4708 "set i [expr {$active + $count}]\n"
4709 "}\n"
4710 "while {1} {\n"
4711 "if {$quitAfter <= 0} {\n"
4712 "return\n"
4713 "}\n"
4714 "while {$i < 0} {\n"
4715 "incr i $length\n"
4716 "}\n"
4717 "while {$i >= $length} {\n"
4718 "incr i -$length\n"
4719 "}\n"
4720 "if {[catch {$menu entrycget $i -state} state] == 0} {\n"
4721 "if {[string compare $state \"disabled\"]} {\n"
4722 "break\n"
4723 "}\n"
4724 "}\n"
4725 "if {$i == $active} {\n"
4726 "return\n"
4727 "}\n"
4728 "incr i $count\n"
4729 "incr quitAfter -1\n"
4730 "}\n"
4731 "$menu activate $i\n"
4732 "tkGenerateMenuSelect $menu\n"
4733 "if {[string equal [$menu type $i] \"cascade\"]} {\n"
4734 "set cascade [$menu entrycget $i -menu]\n"
4735 "if {[string compare $cascade \"\"]} {\n"
4736 "$menu postcascade $i\n"
4737 "tkMenuFirstEntry $cascade\n"
4738 "}\n"
4739 "}\n"
4740 "}\n"
4741 "proc tkMenuFind {w char} {\n"
4742 "global tkPriv\n"
4743 "set char [string tolower $char]\n"
4744 "set windowlist [winfo child $w]\n"
4745 "foreach child $windowlist {\n"
4746 "if {[string compare [winfo toplevel [focus]] \\\n"
4747 "\011\011[winfo toplevel $child]]} {\n"
4748 "continue\n"
4749 "}\n"
4750 "if {[string equal [winfo class $child] \"Menu\"] && \\\n"
4751 "\011\011[string equal [$child cget -type] \"menubar\"]} {\n"
4752 "if {[string equal $char \"\"]} {\n"
4753 "return $child\n"
4754 "}\n"
4755 "set last [$child index last]\n"
4756 "for {set i [$child cget -tearoff]} {$i <= $last} {incr i} {\n"
4757 "if {[string equal [$child type $i] \"separator\"]} {\n"
4758 "continue\n"
4759 "}\n"
4760 "set char2 [string index [$child entrycget $i -label] \\\n"
4761 "\011\011\011[$child entrycget $i -underline]]\n"
4762 "if {[string equal $char [string tolower $char2]] \\\n"
4763 "\011\011\011|| [string equal $char \"\"]} {\n"
4764 "if {[string compare [$child entrycget $i -state] \"disabled\"]} {\n"
4765 "return $child\n"
4766 "}\n"
4767 "}\n"
4768 "}\n"
4769 "}\n"
4770 "}\n"
4771 "foreach child $windowlist {\n"
4772 "if {[string compare [winfo toplevel [focus]] \\\n"
4773 "\011\011[winfo toplevel $child]]} {\n"
4774 "continue\n"
4775 "}\n"
4776 "switch [winfo class $child] {\n"
4777 "Menubutton {\n"
4778 "set char2 [string index [$child cget -text] \\\n"
4779 "\011\011\011[$child cget -underline]]\n"
4780 "if {[string equal $char [string tolower $char2]] \\\n"
4781 "\011\011\011|| [string equal $char \"\"]} {\n"
4782 "if {[string compare [$child cget -state] \"disabled\"]} {\n"
4783 "return $child\n"
4784 "}\n"
4785 "}\n"
4786 "}\n"
4787 "default {\n"
4788 "set match [tkMenuFind $child $char]\n"
4789 "if {[string compare $match \"\"]} {\n"
4790 "return $match\n"
4791 "}\n"
4792 "}\n"
4793 "}\n"
4794 "}\n"
4795 "return {}\n"
4796 "}\n"
4797 "proc tkTraverseToMenu {w char} {\n"
4798 "global tkPriv\n"
4799 "if {[string equal $char \"\"]} {\n"
4800 "return\n"
4801 "}\n"
4802 "while {[string equal [winfo class $w] \"Menu\"]} {\n"
4803 "if {[string compare [$w cget -type] \"menubar\"] \\\n"
4804 "\011\011&& [string equal $tkPriv(postedMb) \"\"]} {\n"
4805 "return\n"
4806 "}\n"
4807 "if {[string equal [$w cget -type] \"menubar\"]} {\n"
4808 "break\n"
4809 "}\n"
4810 "set w [winfo parent $w]\n"
4811 "}\n"
4812 "set w [tkMenuFind [winfo toplevel $w] $char]\n"
4813 "if {[string compare $w \"\"]} {\n"
4814 "if {[string equal [winfo class $w] \"Menu\"]} {\n"
4815 "tk_menuSetFocus $w\n"
4816 "set tkPriv(window) $w\n"
4817 "tkSaveGrabInfo $w\n"
4818 "grab -global $w\n"
4819 "tkTraverseWithinMenu $w $char\n"
4820 "} else {\n"
4821 "tkMbPost $w\n"
4822 "tkMenuFirstEntry [$w cget -menu]\n"
4823 "}\n"
4824 "}\n"
4825 "}\n"
4826 "proc tkFirstMenu w {\n"
4827 "set w [tkMenuFind [winfo toplevel $w] \"\"]\n"
4828 "if {[string compare $w \"\"]} {\n"
4829 "if {[string equal [winfo class $w] \"Menu\"]} {\n"
4830 "tk_menuSetFocus $w\n"
4831 "set tkPriv(window) $w\n"
4832 "tkSaveGrabInfo $w\n"
4833 "grab -global $w\n"
4834 "tkMenuFirstEntry $w\n"
4835 "} else {\n"
4836 "tkMbPost $w\n"
4837 "tkMenuFirstEntry [$w cget -menu]\n"
4838 "}\n"
4839 "}\n"
4840 "}\n"
4841 "proc tkTraverseWithinMenu {w char} {\n"
4842 "if {[string equal $char \"\"]} {\n"
4843 "return\n"
4844 "}\n"
4845 "set char [string tolower $char]\n"
4846 "set last [$w index last]\n"
4847 "if {[string equal $last \"none\"]} {\n"
4848 "return\n"
4849 "}\n"
4850 "for {set i 0} {$i <= $last} {incr i} {\n"
4851 "if {[catch {set char2 [string index \\\n"
4852 "\011\011[$w entrycget $i -label] [$w entrycget $i -underline]]}]} {\n"
4853 "continue\n"
4854 "}\n"
4855 "if {[string equal $char [string tolower $char2]]} {\n"
4856 "if {[string equal [$w type $i] \"cascade\"]} {\n"
4857 "$w activate $i\n"
4858 "$w postcascade active\n"
4859 "event generate $w <<MenuSelect>>\n"
4860 "set m2 [$w entrycget $i -menu]\n"
4861 "if {[string compare $m2 \"\"]} {\n"
4862 "tkMenuFirstEntry $m2\n"
4863 "}\n"
4864 "} else {\n"
4865 "tkMenuUnpost $w\n"
4866 "uplevel #0 [list $w invoke $i]\n"
4867 "}\n"
4868 "return\n"
4869 "}\n"
4870 "}\n"
4871 "}\n"
4872 "proc tkMenuFirstEntry menu {\n"
4873 "if {[string equal $menu \"\"]} {\n"
4874 "return\n"
4875 "}\n"
4876 "tk_menuSetFocus $menu\n"
4877 "if {[string compare [$menu index active] \"none\"]} {\n"
4878 "return\n"
4879 "}\n"
4880 "set last [$menu index last]\n"
4881 "if {[string equal $last \"none\"]} {\n"
4882 "return\n"
4883 "}\n"
4884 "for {set i 0} {$i <= $last} {incr i} {\n"
4885 "if {([catch {set state [$menu entrycget $i -state]}] == 0) \\\n"
4886 "\011\011&& [string compare $state \"disabled\"] \\\n"
4887 "\011\011&& [string compare [$menu type $i] \"tearoff\"]} {\n"
4888 "$menu activate $i\n"
4889 "tkGenerateMenuSelect $menu\n"
4890 "if {[string equal [$menu type $i] \"cascade\"] && \\\n"
4891 "\011\011[string equal [$menu cget -type] \"menubar\"]} {\n"
4892 "set cascade [$menu entrycget $i -menu]\n"
4893 "if {[string compare $cascade \"\"]} {\n"
4894 "$menu postcascade $i\n"
4895 "tkMenuFirstEntry $cascade\n"
4896 "}\n"
4897 "}\n"
4898 "return\n"
4899 "}\n"
4900 "}\n"
4901 "}\n"
4902 "proc tkMenuFindName {menu s} {\n"
4903 "set i \"\"\n"
4904 "if {![regexp {^active$|^last$|^none$|^[0-9]|^@} $s]} {\n"
4905 "catch {set i [$menu index $s]}\n"
4906 "return $i\n"
4907 "}\n"
4908 "set last [$menu index last]\n"
4909 "if {[string equal $last \"none\"]} {\n"
4910 "return\n"
4911 "}\n"
4912 "for {set i 0} {$i <= $last} {incr i} {\n"
4913 "if {![catch {$menu entrycget $i -label} label]} {\n"
4914 "if {[string equal $label $s]} {\n"
4915 "return $i\n"
4916 "}\n"
4917 "}\n"
4918 "}\n"
4919 "return \"\"\n"
4920 "}\n"
4921 "proc tkPostOverPoint {menu x y {entry {}}} {\n"
4922 "global tcl_platform\n"
4923 "if {[string compare $entry {}]} {\n"
4924 "if {$entry == [$menu index last]} {\n"
4925 "incr y [expr {-([$menu yposition $entry] \\\n"
4926 "\011\011 + [winfo reqheight $menu])/2}]\n"
4927 "} else {\n"
4928 "incr y [expr {-([$menu yposition $entry] \\\n"
4929 "\011\011 + [$menu yposition [expr {$entry+1}]])/2}]\n"
4930 "}\n"
4931 "incr x [expr {-[winfo reqwidth $menu]/2}]\n"
4932 "}\n"
4933 "$menu post $x $y\n"
4934 "if {[string compare $entry {}] \\\n"
4935 "\011 && [string compare [$menu entrycget $entry -state] \"disabled\"]} {\n"
4936 "$menu activate $entry\n"
4937 "tkGenerateMenuSelect $menu\n"
4938 "}\n"
4939 "}\n"
4940 "proc tkSaveGrabInfo w {\n"
4941 "global tkPriv\n"
4942 "set tkPriv(oldGrab) [grab current $w]\n"
4943 "if {[string compare $tkPriv(oldGrab) \"\"]} {\n"
4944 "set tkPriv(grabStatus) [grab status $tkPriv(oldGrab)]\n"
4945 "}\n"
4946 "}\n"
4947 "proc tkRestoreOldGrab {} {\n"
4948 "global tkPriv\n"
4949 "if {[string compare $tkPriv(oldGrab) \"\"]} {\n"
4950 "catch {\n"
4951 "if {[string equal $tkPriv(grabStatus) \"global\"]} {\n"
4952 "grab set -global $tkPriv(oldGrab)\n"
4953 "} else {\n"
4954 "grab set $tkPriv(oldGrab)\n"
4955 "}\n"
4956 "}\n"
4957 "set tkPriv(oldGrab) \"\"\n"
4958 "}\n"
4959 "}\n"
4960 "proc tk_menuSetFocus {menu} {\n"
4961 "global tkPriv\n"
4962 "if {![info exists tkPriv(focus)] || [string equal $tkPriv(focus) {}]} {\n"
4963 "set tkPriv(focus) [focus]\n"
4964 "}\n"
4965 "focus $menu\n"
4966 "}\n"
4967 "proc tkGenerateMenuSelect {menu} {\n"
4968 "global tkPriv\n"
4969 "if {[string equal $tkPriv(activeMenu) $menu] \\\n"
4970 " && [string equal $tkPriv(activeItem) [$menu index active]]} {\n"
4971 "return\n"
4972 "}\n"
4973 "set tkPriv(activeMenu) $menu\n"
4974 "set tkPriv(activeItem) [$menu index active]\n"
4975 "event generate $menu <<MenuSelect>>\n"
4976 "}\n"
4977 "proc tk_popup {menu x y {entry {}}} {\n"
4978 "global tkPriv\n"
4979 "global tcl_platform\n"
4980 "if {[string compare $tkPriv(popup) \"\"] \\\n"
4981 "\011 || [string compare $tkPriv(postedMb) \"\"]} {\n"
4982 "tkMenuUnpost {}\n"
4983 "}\n"
4984 "tkPostOverPoint $menu $x $y $entry\n"
4985 "if {[string equal $tcl_platform(platform) \"unix\"] \\\n"
4986 "\011 && [winfo viewable $menu]} {\n"
4987 "tkSaveGrabInfo $menu\n"
4988 "grab -global $menu\n"
4989 "set tkPriv(popup) $menu\n"
4990 "tk_menuSetFocus $menu\n"
4991 "}\n"
4992 "}\n"
4993 ;
4994 static char Et_zFile18[] =
4995 "namespace eval ::tk::dialog {}\n"
4996 "image create bitmap ::tk::dialog::b1 -foreground black \\\n"
4997 "-data \"#define b1_width 32\\n#define b1_height 32\n"
4998 "static unsigned char q1_bits[] = {\n"
4999 "0x00, 0xf8, 0x1f, 0x00, 0x00, 0x07, 0xe0, 0x00, 0xc0, 0x00, 0x00, 0x03,\n"
5000 "0x20, 0x00, 0x00, 0x04, 0x10, 0x00, 0x00, 0x08, 0x08, 0x00, 0x00, 0x10,\n"
5001 "0x04, 0x00, 0x00, 0x20, 0x02, 0x00, 0x00, 0x40, 0x02, 0x00, 0x00, 0x40,\n"
5002 "0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80,\n"
5003 "0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80,\n"
5004 "0x01, 0x00, 0x00, 0x80, 0x02, 0x00, 0x00, 0x40, 0x02, 0x00, 0x00, 0x40,\n"
5005 "0x04, 0x00, 0x00, 0x20, 0x08, 0x00, 0x00, 0x10, 0x10, 0x00, 0x00, 0x08,\n"
5006 "0x60, 0x00, 0x00, 0x04, 0x80, 0x03, 0x80, 0x03, 0x00, 0x0c, 0x78, 0x00,\n"
5007 "0x00, 0x30, 0x04, 0x00, 0x00, 0x40, 0x04, 0x00, 0x00, 0x40, 0x04, 0x00,\n"
5008 "0x00, 0x80, 0x04, 0x00, 0x00, 0x00, 0x05, 0x00, 0x00, 0x00, 0x06, 0x00,\n"
5009 "0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};\"\n"
5010 "image create bitmap ::tk::dialog::b2 -foreground white \\\n"
5011 "-data \"#define b2_width 32\\n#define b2_height 32\n"
5012 "static unsigned char b2_bits[] = {\n"
5013 "0x00, 0x00, 0x00, 0x00, 0x00, 0xf8, 0x1f, 0x00, 0x00, 0xff, 0xff, 0x00,\n"
5014 "0xc0, 0xff, 0xff, 0x03, 0xe0, 0xff, 0xff, 0x07, 0xf0, 0xff, 0xff, 0x0f,\n"
5015 "0xf8, 0xff, 0xff, 0x1f, 0xfc, 0xff, 0xff, 0x3f, 0xfc, 0xff, 0xff, 0x3f,\n"
5016 "0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f,\n"
5017 "0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f,\n"
5018 "0xfe, 0xff, 0xff, 0x7f, 0xfc, 0xff, 0xff, 0x3f, 0xfc, 0xff, 0xff, 0x3f,\n"
5019 "0xf8, 0xff, 0xff, 0x1f, 0xf0, 0xff, 0xff, 0x0f, 0xe0, 0xff, 0xff, 0x07,\n"
5020 "0x80, 0xff, 0xff, 0x03, 0x00, 0xfc, 0x7f, 0x00, 0x00, 0xf0, 0x07, 0x00,\n"
5021 "0x00, 0xc0, 0x03, 0x00, 0x00, 0x80, 0x03, 0x00, 0x00, 0x80, 0x03, 0x00,\n"
5022 "0x00, 0x00, 0x03, 0x00, 0x00, 0x00, 0x02, 0x00, 0x00, 0x00, 0x00, 0x00,\n"
5023 "0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};\"\n"
5024 "image create bitmap ::tk::dialog::q -foreground blue \\\n"
5025 "-data \"#define q_width 32\\n#define q_height 32\n"
5026 "static unsigned char q_bits[] = {\n"
5027 "0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,\n"
5028 "0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xe0, 0x07, 0x00,\n"
5029 "0x00, 0x10, 0x0f, 0x00, 0x00, 0x18, 0x1e, 0x00, 0x00, 0x38, 0x1e, 0x00,\n"
5030 "0x00, 0x38, 0x1e, 0x00, 0x00, 0x10, 0x0f, 0x00, 0x00, 0x80, 0x07, 0x00,\n"
5031 "0x00, 0xc0, 0x01, 0x00, 0x00, 0xc0, 0x00, 0x00, 0x00, 0xc0, 0x00, 0x00,\n"
5032 "0x00, 0x00, 0x00, 0x00, 0x00, 0xc0, 0x00, 0x00, 0x00, 0xe0, 0x01, 0x00,\n"
5033 "0x00, 0xe0, 0x01, 0x00, 0x00, 0xc0, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,\n"
5034 "0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,\n"
5035 "0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,\n"
5036 "0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,\n"
5037 "0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};\"\n"
5038 "image create bitmap ::tk::dialog::i -foreground blue \\\n"
5039 "-data \"#define i_width 32\\n#define i_height 32\n"
5040 "static unsigned char i_bits[] = {\n"
5041 "0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,\n"
5042 "0x00, 0xe0, 0x01, 0x00, 0x00, 0xf0, 0x03, 0x00, 0x00, 0xf0, 0x03, 0x00,\n"
5043 "0x00, 0xe0, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,\n"
5044 "0x00, 0xf8, 0x03, 0x00, 0x00, 0xf0, 0x03, 0x00, 0x00, 0xe0, 0x03, 0x00,\n"
5045 "0x00, 0xe0, 0x03, 0x00, 0x00, 0xe0, 0x03, 0x00, 0x00, 0xe0, 0x03, 0x00,\n"
5046 "0x00, 0xe0, 0x03, 0x00, 0x00, 0xe0, 0x03, 0x00, 0x00, 0xf0, 0x07, 0x00,\n"
5047 "0x00, 0xf8, 0x0f, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,\n"
5048 "0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,\n"
5049 "0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,\n"
5050 "0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,\n"
5051 "0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};\"\n"
5052 "image create bitmap ::tk::dialog::w1 -foreground black \\\n"
5053 "-data \"#define w1_width 32\\n#define w1_height 32\n"
5054 "static unsigned char w1_bits[] = {\n"
5055 "0x00, 0x80, 0x01, 0x00, 0x00, 0x40, 0x02, 0x00, 0x00, 0x20, 0x04, 0x00,\n"
5056 "0x00, 0x10, 0x04, 0x00, 0x00, 0x10, 0x08, 0x00, 0x00, 0x08, 0x08, 0x00,\n"
5057 "0x00, 0x08, 0x10, 0x00, 0x00, 0x04, 0x10, 0x00, 0x00, 0x04, 0x20, 0x00,\n"
5058 "0x00, 0x02, 0x20, 0x00, 0x00, 0x02, 0x40, 0x00, 0x00, 0x01, 0x40, 0x00,\n"
5059 "0x00, 0x01, 0x80, 0x00, 0x80, 0x00, 0x80, 0x00, 0x80, 0x00, 0x00, 0x01,\n"
5060 "0x40, 0x00, 0x00, 0x01, 0x40, 0x00, 0x00, 0x02, 0x20, 0x00, 0x00, 0x02,\n"
5061 "0x20, 0x00, 0x00, 0x04, 0x10, 0x00, 0x00, 0x04, 0x10, 0x00, 0x00, 0x08,\n"
5062 "0x08, 0x00, 0x00, 0x08, 0x08, 0x00, 0x00, 0x10, 0x04, 0x00, 0x00, 0x10,\n"
5063 "0x04, 0x00, 0x00, 0x20, 0x02, 0x00, 0x00, 0x20, 0x01, 0x00, 0x00, 0x40,\n"
5064 "0x01, 0x00, 0x00, 0x40, 0x01, 0x00, 0x00, 0x40, 0x02, 0x00, 0x00, 0x20,\n"
5065 "0xfc, 0xff, 0xff, 0x1f, 0x00, 0x00, 0x00, 0x00};\"\n"
5066 "image create bitmap ::tk::dialog::w2 -foreground yellow \\\n"
5067 "-data \"#define w2_width 32\\n#define w2_height 32\n"
5068 "static unsigned char w2_bits[] = {\n"
5069 "0x00, 0x00, 0x00, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0xc0, 0x03, 0x00,\n"
5070 "0x00, 0xe0, 0x03, 0x00, 0x00, 0xe0, 0x07, 0x00, 0x00, 0xf0, 0x07, 0x00,\n"
5071 "0x00, 0xf0, 0x0f, 0x00, 0x00, 0xf8, 0x0f, 0x00, 0x00, 0xf8, 0x1f, 0x00,\n"
5072 "0x00, 0xfc, 0x1f, 0x00, 0x00, 0xfc, 0x3f, 0x00, 0x00, 0xfe, 0x3f, 0x00,\n"
5073 "0x00, 0xfe, 0x7f, 0x00, 0x00, 0xff, 0x7f, 0x00, 0x00, 0xff, 0xff, 0x00,\n"
5074 "0x80, 0xff, 0xff, 0x00, 0x80, 0xff, 0xff, 0x01, 0xc0, 0xff, 0xff, 0x01,\n"
5075 "0xc0, 0xff, 0xff, 0x03, 0xe0, 0xff, 0xff, 0x03, 0xe0, 0xff, 0xff, 0x07,\n"
5076 "0xf0, 0xff, 0xff, 0x07, 0xf0, 0xff, 0xff, 0x0f, 0xf8, 0xff, 0xff, 0x0f,\n"
5077 "0xf8, 0xff, 0xff, 0x1f, 0xfc, 0xff, 0xff, 0x1f, 0xfe, 0xff, 0xff, 0x3f,\n"
5078 "0xfe, 0xff, 0xff, 0x3f, 0xfe, 0xff, 0xff, 0x3f, 0xfc, 0xff, 0xff, 0x1f,\n"
5079 "0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};\"\n"
5080 "image create bitmap ::tk::dialog::w3 -foreground black \\\n"
5081 "-data \"#define w3_width 32\\n#define w3_height 32\n"
5082 "static unsigned char w3_bits[] = {\n"
5083 "0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,\n"
5084 "0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,\n"
5085 "0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,\n"
5086 "0x00, 0xc0, 0x03, 0x00, 0x00, 0xe0, 0x07, 0x00, 0x00, 0xe0, 0x07, 0x00,\n"
5087 "0x00, 0xe0, 0x07, 0x00, 0x00, 0xe0, 0x07, 0x00, 0x00, 0xe0, 0x07, 0x00,\n"
5088 "0x00, 0xc0, 0x03, 0x00, 0x00, 0xc0, 0x03, 0x00, 0x00, 0xc0, 0x03, 0x00,\n"
5089 "0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00,\n"
5090 "0x00, 0x00, 0x00, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0xc0, 0x03, 0x00,\n"
5091 "0x00, 0xc0, 0x03, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00,\n"
5092 "0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,\n"
5093 "0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};\"\n"
5094 "proc tkMessageBox {args} {\n"
5095 "global tkPriv tcl_platform tk_strictMotif\n"
5096 "set w tkPrivMsgBox\n"
5097 "upvar #0 $w data\n"
5098 "set specs {\n"
5099 "{-default \"\" \"\" \"\"}\n"
5100 "{-icon \"\" \"\" \"info\"}\n"
5101 "{-message \"\" \"\" \"\"}\n"
5102 "{-parent \"\" \"\" .}\n"
5103 "{-title \"\" \"\" \" \"}\n"
5104 "{-type \"\" \"\" \"ok\"}\n"
5105 "}\n"
5106 "tclParseConfigSpec $w $specs \"\" $args\n"
5107 "if {[lsearch -exact {info warning error question} $data(-icon)] == -1} {\n"
5108 "error \"bad -icon value \\\"$data(-icon)\\\": must be error, info, question, or warning\"\n"
5109 "}\n"
5110 "if {[string equal $tcl_platform(platform) \"macintosh\"]} {\n"
5111 "switch -- $data(-icon) {\n"
5112 "\"error\" {set data(-icon) \"stop\"}\n"
5113 "\"warning\" {set data(-icon) \"caution\"}\n"
5114 "\"info\" {set data(-icon) \"note\"}\n"
5115 "}\n"
5116 "}\n"
5117 "if {![winfo exists $data(-parent)]} {\n"
5118 "error \"bad window path name \\\"$data(-parent)\\\"\"\n"
5119 "}\n"
5120 "switch -- $data(-type) {\n"
5121 "abortretryignore {\n"
5122 "set buttons {\n"
5123 "{abort -width 6 -text Abort -under 0}\n"
5124 "{retry -width 6 -text Retry -under 0}\n"
5125 "{ignore -width 6 -text Ignore -under 0}\n"
5126 "}\n"
5127 "}\n"
5128 "ok {\n"
5129 "set buttons {\n"
5130 "{ok -width 6 -text OK -under 0}\n"
5131 "}\n"
5132 "if {[string equal $data(-default) \"\"]} {\n"
5133 "set data(-default) \"ok\"\n"
5134 "}\n"
5135 "}\n"
5136 "okcancel {\n"
5137 "set buttons {\n"
5138 "{ok -width 6 -text OK -under 0}\n"
5139 "{cancel -width 6 -text Cancel -under 0}\n"
5140 "}\n"
5141 "}\n"
5142 "retrycancel {\n"
5143 "set buttons {\n"
5144 "{retry -width 6 -text Retry -under 0}\n"
5145 "{cancel -width 6 -text Cancel -under 0}\n"
5146 "}\n"
5147 "}\n"
5148 "yesno {\n"
5149 "set buttons {\n"
5150 "{yes -width 6 -text Yes -under 0}\n"
5151 "{no -width 6 -text No -under 0}\n"
5152 "}\n"
5153 "}\n"
5154 "yesnocancel {\n"
5155 "set buttons {\n"
5156 "{yes -width 6 -text Yes -under 0}\n"
5157 "{no -width 6 -text No -under 0}\n"
5158 "{cancel -width 6 -text Cancel -under 0}\n"
5159 "}\n"
5160 "}\n"
5161 "default {\n"
5162 "error \"bad -type value \\\"$data(-type)\\\": must be abortretryignore, ok, okcancel, retrycancel, yesno, or yesnocancel\"\n"
5163 "}\n"
5164 "}\n"
5165 "if {[string compare $data(-default) \"\"]} {\n"
5166 "set valid 0\n"
5167 "foreach btn $buttons {\n"
5168 "if {[string equal [lindex $btn 0] $data(-default)]} {\n"
5169 "set valid 1\n"
5170 "break\n"
5171 "}\n"
5172 "}\n"
5173 "if {!$valid} {\n"
5174 "error \"invalid default button \\\"$data(-default)\\\"\"\n"
5175 "}\n"
5176 "}\n"
5177 "if {[string compare $data(-parent) .]} {\n"
5178 "set w $data(-parent).__tk__messagebox\n"
5179 "} else {\n"
5180 "set w .__tk__messagebox\n"
5181 "}\n"
5182 "catch {destroy $w}\n"
5183 "toplevel $w -class Dialog\n"
5184 "wm title $w $data(-title)\n"
5185 "wm iconname $w Dialog\n"
5186 "wm protocol $w WM_DELETE_WINDOW { }\n"
5187 "if { [winfo viewable [winfo toplevel $data(-parent)]] } {\n"
5188 "wm transient $w $data(-parent)\n"
5189 "} \n"
5190 "if {[string equal $tcl_platform(platform) \"macintosh\"]} {\n"
5191 "unsupported1 style $w dBoxProc\n"
5192 "}\n"
5193 "frame $w.bot\n"
5194 "pack $w.bot -side bottom -fill both\n"
5195 "frame $w.top\n"
5196 "pack $w.top -side top -fill both -expand 1\n"
5197 "if {[string compare $tcl_platform(platform) \"macintosh\"]} {\n"
5198 "$w.bot configure -relief raised -bd 1\n"
5199 "$w.top configure -relief raised -bd 1\n"
5200 "}\n"
5201 "option add *Dialog.msg.wrapLength 3i widgetDefault\n"
5202 "if {[string equal $tcl_platform(platform) \"macintosh\"]} {\n"
5203 "option add *Dialog.msg.font system widgetDefault\n"
5204 "} else {\n"
5205 "option add *Dialog.msg.font {Times 18} widgetDefault\n"
5206 "}\n"
5207 "label $w.msg -anchor nw -justify left -text $data(-message)\n"
5208 "if {[string compare $data(-icon) \"\"]} {\n"
5209 "if {[string equal $tcl_platform(platform) \"macintosh\"] \\\n"
5210 "\011\011|| ([winfo depth $w] < 4) || $tk_strictMotif} {\n"
5211 "label $w.bitmap -bitmap $data(-icon)\n"
5212 "} else {\n"
5213 "canvas $w.bitmap -width 32 -height 32 -highlightthickness 0\n"
5214 "switch $data(-icon) {\n"
5215 "error {\n"
5216 "$w.bitmap create oval 0 0 31 31 -fill red -outline black\n"
5217 "$w.bitmap create line 9 9 23 23 -fill white -width 4\n"
5218 "$w.bitmap create line 9 23 23 9 -fill white -width 4\n"
5219 "}\n"
5220 "info {\n"
5221 "$w.bitmap create image 0 0 -anchor nw \\\n"
5222 "\011\011\011 -image ::tk::dialog::b1\n"
5223 "$w.bitmap create image 0 0 -anchor nw \\\n"
5224 "\011\011\011 -image ::tk::dialog::b2\n"
5225 "$w.bitmap create image 0 0 -anchor nw \\\n"
5226 "\011\011\011 -image ::tk::dialog::i\n"
5227 "}\n"
5228 "question {\n"
5229 "$w.bitmap create image 0 0 -anchor nw \\\n"
5230 "\011\011\011 -image ::tk::dialog::b1\n"
5231 "$w.bitmap create image 0 0 -anchor nw \\\n"
5232 "\011\011\011 -image ::tk::dialog::b2\n"
5233 "$w.bitmap create image 0 0 -anchor nw \\\n"
5234 "\011\011\011 -image ::tk::dialog::q\n"
5235 "}\n"
5236 "default {\n"
5237 "$w.bitmap create image 0 0 -anchor nw \\\n"
5238 "\011\011\011 -image ::tk::dialog::w1\n"
5239 "$w.bitmap create image 0 0 -anchor nw \\\n"
5240 "\011\011\011 -image ::tk::dialog::w2\n"
5241 "$w.bitmap create image 0 0 -anchor nw \\\n"
5242 "\011\011\011 -image ::tk::dialog::w3\n"
5243 "}\n"
5244 "}\n"
5245 "}\n"
5246 "}\n"
5247 "grid $w.bitmap $w.msg -in $w.top -sticky news -padx 2m -pady 2m\n"
5248 "grid columnconfigure $w.top 1 -weight 1\n"
5249 "grid rowconfigure $w.top 0 -weight 1\n"
5250 "set i 0\n"
5251 "foreach but $buttons {\n"
5252 "set name [lindex $but 0]\n"
5253 "set opts [lrange $but 1 end]\n"
5254 "if {![llength $opts]} {\n"
5255 "set capName [string toupper $name 0]\n"
5256 "set opts [list -text $capName]\n"
5257 "}\n"
5258 "eval button [list $w.$name] $opts [list -command [list set tkPriv(button) $name]]\n"
5259 "if {[string equal $name $data(-default)]} {\n"
5260 "$w.$name configure -default active\n"
5261 "}\n"
5262 "pack $w.$name -in $w.bot -side left -expand 1 -padx 3m -pady 2m\n"
5263 "set underIdx [$w.$name cget -under]\n"
5264 "if {$underIdx >= 0} {\n"
5265 "set key [string index [$w.$name cget -text] $underIdx]\n"
5266 "bind $w <Alt-[string tolower $key]> [list $w.$name invoke]\n"
5267 "bind $w <Alt-[string toupper $key]> [list $w.$name invoke]\n"
5268 "}\n"
5269 "incr i\n"
5270 "}\n"
5271 "if {[string compare {} $data(-default)]} {\n"
5272 "bind $w <FocusIn> {\n"
5273 "if {[string equal Button [winfo class %W]]} {\n"
5274 "%W configure -default active\n"
5275 "}\n"
5276 "}\n"
5277 "bind $w <FocusOut> {\n"
5278 "if {[string equal Button [winfo class %W]]} {\n"
5279 "%W configure -default normal\n"
5280 "}\n"
5281 "}\n"
5282 "}\n"
5283 "bind $w <Return> {\n"
5284 "if {[string equal Button [winfo class %W]]} {\n"
5285 "tkButtonInvoke %W\n"
5286 "}\n"
5287 "}\n"
5288 "::tk::PlaceWindow $w widget $data(-parent)\n"
5289 "if {[string compare $data(-default) \"\"]} {\n"
5290 "set focus $w.$data(-default)\n"
5291 "} else {\n"
5292 "set focus $w\n"
5293 "}\n"
5294 "::tk::SetFocusGrab $w $focus\n"
5295 "tkwait variable tkPriv(button)\n"
5296 "::tk::RestoreFocusGrab $w $focus\n"
5297 "return $tkPriv(button)\n"
5298 "}\n"
5299 ;
5300 static char Et_zFile19[] =
5301 "proc tk_menuBar args {}\n"
5302 "proc tk_bindForTraversal args {}\n"
5303 ;
5304 static char Et_zFile20[] =
5305 "proc tk_optionMenu {w varName firstValue args} {\n"
5306 "upvar #0 $varName var\n"
5307 "if {![info exists var]} {\n"
5308 "set var $firstValue\n"
5309 "}\n"
5310 "menubutton $w -textvariable $varName -indicatoron 1 -menu $w.menu \\\n"
5311 "\011 -relief raised -bd 2 -highlightthickness 2 -anchor c \\\n"
5312 "\011 -direction flush\n"
5313 "menu $w.menu -tearoff 0\n"
5314 "$w.menu add radiobutton -label $firstValue -variable $varName\n"
5315 "foreach i $args {\n"
5316 "$w.menu add radiobutton -label $i -variable $varName\n"
5317 "}\n"
5318 "return $w.menu\n"
5319 "}\n"
5320 ;
5321 static char Et_zFile21[] =
5322 "proc tk_setPalette {args} {\n"
5323 "if {[winfo depth .] == 1} {\n"
5324 "return\n"
5325 "}\n"
5326 "global tkPalette\n"
5327 "if {[llength $args] == 1} {\n"
5328 "set new(background) [lindex $args 0]\n"
5329 "} else {\n"
5330 "array set new $args\n"
5331 "}\n"
5332 "if {![info exists new(background)]} {\n"
5333 "error \"must specify a background color\"\n"
5334 "}\n"
5335 "if {![info exists new(foreground)]} {\n"
5336 "set new(foreground) black\n"
5337 "}\n"
5338 "set bg [winfo rgb . $new(background)]\n"
5339 "set fg [winfo rgb . $new(foreground)]\n"
5340 "set darkerBg [format #%02x%02x%02x [expr {(9*[lindex $bg 0])/2560}] \\\n"
5341 "\011 [expr {(9*[lindex $bg 1])/2560}] [expr {(9*[lindex $bg 2])/2560}]]\n"
5342 "foreach i {activeForeground insertBackground selectForeground \\\n"
5343 "\011 highlightColor} {\n"
5344 "if {![info exists new($i)]} {\n"
5345 "set new($i) $new(foreground)\n"
5346 "}\n"
5347 "}\n"
5348 "if {![info exists new(disabledForeground)]} {\n"
5349 "set new(disabledForeground) [format #%02x%02x%02x \\\n"
5350 "\011\011[expr {(3*[lindex $bg 0] + [lindex $fg 0])/1024}] \\\n"
5351 "\011\011[expr {(3*[lindex $bg 1] + [lindex $fg 1])/1024}] \\\n"
5352 "\011\011[expr {(3*[lindex $bg 2] + [lindex $fg 2])/1024}]]\n"
5353 "}\n"
5354 "if {![info exists new(highlightBackground)]} {\n"
5355 "set new(highlightBackground) $new(background)\n"
5356 "}\n"
5357 "if {![info exists new(activeBackground)]} {\n"
5358 "foreach i {0 1 2} {\n"
5359 "set light($i) [expr {[lindex $bg $i]/256}]\n"
5360 "set inc1 [expr {($light($i)*15)/100}]\n"
5361 "set inc2 [expr {(255-$light($i))/3}]\n"
5362 "if {$inc1 > $inc2} {\n"
5363 "incr light($i) $inc1\n"
5364 "} else {\n"
5365 "incr light($i) $inc2\n"
5366 "}\n"
5367 "if {$light($i) > 255} {\n"
5368 "set light($i) 255\n"
5369 "}\n"
5370 "}\n"
5371 "set new(activeBackground) [format #%02x%02x%02x $light(0) \\\n"
5372 "\011\011$light(1) $light(2)]\n"
5373 "}\n"
5374 "if {![info exists new(selectBackground)]} {\n"
5375 "set new(selectBackground) $darkerBg\n"
5376 "}\n"
5377 "if {![info exists new(troughColor)]} {\n"
5378 "set new(troughColor) $darkerBg\n"
5379 "}\n"
5380 "if {![info exists new(selectColor)]} {\n"
5381 "set new(selectColor) #b03060\n"
5382 "}\n"
5383 "toplevel .___tk_set_palette\n"
5384 "wm withdraw .___tk_set_palette\n"
5385 "foreach q {button canvas checkbutton entry frame label listbox \\\n"
5386 "\011 menubutton menu message radiobutton scale scrollbar text} {\n"
5387 "$q .___tk_set_palette.$q\n"
5388 "}\n"
5389 "eval [tkRecolorTree . new]\n"
5390 "catch {destroy .___tk_set_palette}\n"
5391 "foreach option [array names new] {\n"
5392 "option add *$option $new($option) widgetDefault\n"
5393 "}\n"
5394 "array set tkPalette [array get new]\n"
5395 "}\n"
5396 "proc tkRecolorTree {w colors} {\n"
5397 "global tkPalette\n"
5398 "upvar $colors c\n"
5399 "set result {}\n"
5400 "foreach dbOption [array names c] {\n"
5401 "set option -[string tolower $dbOption]\n"
5402 "if {![catch {$w config $option} value]} {\n"
5403 "set defaultcolor [option get $w $dbOption widgetDefault]\n"
5404 "if {[string match {} $defaultcolor]} {\n"
5405 "set defaultcolor [winfo rgb . [lindex $value 3]]\n"
5406 "} else {\n"
5407 "set defaultcolor [winfo rgb . $defaultcolor]\n"
5408 "}\n"
5409 "set chosencolor [winfo rgb . [lindex $value 4]]\n"
5410 "if {[string match $defaultcolor $chosencolor]} {\n"
5411 "append result \";\\noption add [list \\\n"
5412 "\011\011 *[winfo class $w].$dbOption $c($dbOption) 60]\"\n"
5413 "$w configure $option $c($dbOption)\n"
5414 "}\n"
5415 "}\n"
5416 "}\n"
5417 "foreach child [winfo children $w] {\n"
5418 "append result \";\\n[tkRecolorTree $child c]\"\n"
5419 "}\n"
5420 "return $result\n"
5421 "}\n"
5422 "proc tkDarken {color percent} {\n"
5423 "foreach {red green blue} [winfo rgb . $color] {\n"
5424 "set red [expr {($red/256)*$percent/100}]\n"
5425 "set green [expr {($green/256)*$percent/100}]\n"
5426 "set blue [expr {($blue/256)*$percent/100}]\n"
5427 "break\n"
5428 "}\n"
5429 "if {$red > 255} {\n"
5430 "set red 255\n"
5431 "}\n"
5432 "if {$green > 255} {\n"
5433 "set green 255\n"
5434 "}\n"
5435 "if {$blue > 255} {\n"
5436 "set blue 255\n"
5437 "}\n"
5438 "return [format \"#%02x%02x%02x\" $red $green $blue]\n"
5439 "}\n"
5440 "proc tk_bisque {} {\n"
5441 "tk_setPalette activeBackground #e6ceb1 activeForeground black \\\n"
5442 "\011 background #ffe4c4 disabledForeground #b0b0b0 foreground black \\\n"
5443 "\011 highlightBackground #ffe4c4 highlightColor black \\\n"
5444 "\011 insertBackground black selectColor #b03060 \\\n"
5445 "\011 selectBackground #e6ceb1 selectForeground black \\\n"
5446 "\011 troughColor #cdb79e\n"
5447 "}\n"
5448 ;
5449 static char Et_zFile22[] =
5450 "package require opt 0.4.1;\n"
5451 "namespace eval ::safe {\n"
5452 "variable tkSafeId 0;\n"
5453 "proc ::safe::tkInterpInit {slave argv} {\n"
5454 "global env tk_library\n"
5455 "allowTk $slave $argv\n"
5456 "::interp eval $slave [list set tk_library [::safe::interpAddToAccessPath $slave $tk_library]]\n"
5457 "return $slave\n"
5458 "}\n"
5459 "proc ::safe::loadTk {} {}\n"
5460 "::tcl::OptProc loadTk {\n"
5461 "{slave -interp \"name of the slave interpreter\"}\n"
5462 "{-use -windowId {} \"window Id to use (new toplevel otherwise)\"}\n"
5463 "{-display -displayName {} \"display name to use (current one otherwise)\"}\n"
5464 "} {\n"
5465 "set displayGiven [::tcl::OptProcArgGiven \"-display\"]\n"
5466 "if {!$displayGiven} {\n"
5467 "if {[catch {set display [winfo screen .]}]} {\n"
5468 "if {[info exists ::env(DISPLAY)]} {\n"
5469 "set display $::env(DISPLAY)\n"
5470 "} else {\n"
5471 "Log $slave \"no winfo screen . nor env(DISPLAY)\" WARNING\n"
5472 "set display \":0.0\"\n"
5473 "}\n"
5474 "}\n"
5475 "}\n"
5476 "if {![::tcl::OptProcArgGiven \"-use\"]} {\n"
5477 "::tcl::Lassign [tkTopLevel $slave $display] w use\n"
5478 "Set [DeleteHookName $slave] [list tkDelete {} $w]\n"
5479 "} else {\n"
5480 "Set [DeleteHookName $slave] [list disallowTk]\n"
5481 "if {[string match \".*\" $use]} {\n"
5482 "set windowName $use\n"
5483 "set use [winfo id $windowName]\n"
5484 "set nDisplay [winfo screen $windowName]\n"
5485 "} else {\n"
5486 "if {![catch {winfo pathname $use} name]} {\n"
5487 "set nDisplay [winfo screen $name]\n"
5488 "} else {\n"
5489 "set nDisplay $display\n"
5490 "}\n"
5491 "}\n"
5492 "if {[string compare $nDisplay $display]} {\n"
5493 "if {$displayGiven} {\n"
5494 "error \"conflicting -display $display and -use\\\n"
5495 "\011\011\011$use -> $nDisplay\"\n"
5496 "} else {\n"
5497 "set display $nDisplay\n"
5498 "}\n"
5499 "}\n"
5500 "}\n"
5501 "tkInterpInit $slave [list \"-use\" $use \"-display\" $display]\n"
5502 "load {} Tk $slave\n"
5503 "return $slave\n"
5504 "}\n"
5505 "proc ::safe::TkInit {interpPath} {\n"
5506 "variable tkInit\n"
5507 "if {[info exists tkInit($interpPath)]} {\n"
5508 "set value $tkInit($interpPath)\n"
5509 "Log $interpPath \"TkInit called, returning \\\"$value\\\"\" NOTICE\n"
5510 "return $value\n"
5511 "} else {\n"
5512 "Log $interpPath \"TkInit called for interp with clearance:\\\n"
5513 "\011\011preventing Tk init\" ERROR\n"
5514 "error \"not allowed\"\n"
5515 "}\n"
5516 "}\n"
5517 "proc ::safe::allowTk {interpPath argv} {\n"
5518 "variable tkInit\n"
5519 "set tkInit($interpPath) $argv\n"
5520 "return\n"
5521 "}\n"
5522 "proc ::safe::disallowTk {interpPath} {\n"
5523 "variable tkInit\n"
5524 "if {[info exists tkInit($interpPath)]} {\n"
5525 "unset tkInit($interpPath)\n"
5526 "}\n"
5527 "return\n"
5528 "}\n"
5529 "proc ::safe::tkDelete {W window slave} {\n"
5530 "Log $slave \"Called tkDelete $W $window\" NOTICE\n"
5531 "if {[::interp exists $slave]} {\n"
5532 "if {[catch {::safe::interpDelete $slave} msg]} {\n"
5533 "Log $slave \"Deletion error : $msg\"\n"
5534 "}\n"
5535 "}\n"
5536 "if {[winfo exists $window]} {\n"
5537 "Log $slave \"Destroy toplevel $window\" NOTICE\n"
5538 "destroy $window\n"
5539 "}\n"
5540 "disallowTk $slave\n"
5541 "return\n"
5542 "}\n"
5543 "proc ::safe::tkTopLevel {slave display} {\n"
5544 "variable tkSafeId\n"
5545 "incr tkSafeId\n"
5546 "set w \".safe$tkSafeId\"\n"
5547 "if {[catch {toplevel $w -screen $display -class SafeTk} msg]} {\n"
5548 "return -code error \"Unable to create toplevel for\\\n"
5549 "\011\011safe slave \\\"$slave\\\" ($msg)\"\n"
5550 "}\n"
5551 "Log $slave \"New toplevel $w\" NOTICE\n"
5552 "set msg \"Untrusted Tcl applet ($slave)\"\n"
5553 "wm title $w $msg\n"
5554 "set wc $w.fc\n"
5555 "frame $wc -bg red -borderwidth 3 -relief ridge\n"
5556 "bindtags $wc [concat Safe$wc [bindtags $wc]]\n"
5557 "bind Safe$wc <Destroy> [list ::safe::tkDelete %W $w $slave]\n"
5558 "label $wc.l -text $msg -padx 2 -pady 0 -anchor w\n"
5559 "frame $wc.fb -bd 0\n"
5560 "button $wc.fb.b -text \"Delete\" \\\n"
5561 "\011 -bd 1 -padx 2 -pady 0 -highlightthickness 0 \\\n"
5562 "\011 -command [list ::safe::tkDelete $w $w $slave]\n"
5563 "pack $wc.fb.b -side right -fill both\n"
5564 "pack $wc.fb -side right -fill both -expand 1\n"
5565 "pack $wc.l -side left -fill both -expand 1\n"
5566 "pack $wc -side bottom -fill x\n"
5567 "frame $w.c -container 1\n"
5568 "pack $w.c -fill both -expand 1\n"
5569 "list $w [winfo id $w.c]\n"
5570 "}\n"
5571 "}\n"
5572 ;
5573 static char Et_zFile23[] =
5574 "bind Scale <Enter> {\n"
5575 "if {$tk_strictMotif} {\n"
5576 "set tkPriv(activeBg) [%W cget -activebackground]\n"
5577 "%W config -activebackground [%W cget -background]\n"
5578 "}\n"
5579 "tkScaleActivate %W %x %y\n"
5580 "}\n"
5581 "bind Scale <Motion> {\n"
5582 "tkScaleActivate %W %x %y\n"
5583 "}\n"
5584 "bind Scale <Leave> {\n"
5585 "if {$tk_strictMotif} {\n"
5586 "%W config -activebackground $tkPriv(activeBg)\n"
5587 "}\n"
5588 "if {[string equal [%W cget -state] \"active\"]} {\n"
5589 "%W configure -state normal\n"
5590 "}\n"
5591 "}\n"
5592 "bind Scale <1> {\n"
5593 "tkScaleButtonDown %W %x %y\n"
5594 "}\n"
5595 "bind Scale <B1-Motion> {\n"
5596 "tkScaleDrag %W %x %y\n"
5597 "}\n"
5598 "bind Scale <B1-Leave> { }\n"
5599 "bind Scale <B1-Enter> { }\n"
5600 "bind Scale <ButtonRelease-1> {\n"
5601 "tkCancelRepeat\n"
5602 "tkScaleEndDrag %W\n"
5603 "tkScaleActivate %W %x %y\n"
5604 "}\n"
5605 "bind Scale <2> {\n"
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"
5638 "}\n"
5639 "bind Scale <Control-Left> {\n"
5640 "tkScaleIncrement %W up big noRepeat\n"
5641 "}\n"
5642 "bind Scale <Control-Right> {\n"
5643 "tkScaleIncrement %W down big noRepeat\n"
5644 "}\n"
5645 "bind Scale <Home> {\n"
5646 "%W set [%W cget -from]\n"
5647 "}\n"
5648 "bind Scale <End> {\n"
5649 "%W set [%W cget -to]\n"
5650 "}\n"
5651 "proc tkScaleActivate {w x y} {\n"
5652 "if {[string equal [$w cget -state] \"disabled\"]} {\n"
5653 "return\n"
5654 "}\n"
5655 "if {[string equal [$w identify $x $y] \"slider\"]} {\n"
5656 "set state active\n"
5657 "} else {\n"
5658 "set state normal\n"
5659 "}\n"
5660 "if {[string compare [$w cget -state] $state]} {\n"
5661 "$w configure -state $state\n"
5662 "}\n"
5663 "}\n"
5664 "proc tkScaleButtonDown {w x y} {\n"
5665 "global tkPriv\n"
5666 "set tkPriv(dragging) 0\n"
5667 "set el [$w identify $x $y]\n"
5668 "if {[string equal $el \"trough1\"]} {\n"
5669 "tkScaleIncrement $w up little initial\n"
5670 "} elseif {[string equal $el \"trough2\"]} {\n"
5671 "tkScaleIncrement $w down little initial\n"
5672 "} elseif {[string equal $el \"slider\"]} {\n"
5673 "set tkPriv(dragging) 1\n"
5674 "set tkPriv(initValue) [$w get]\n"
5675 "set coords [$w coords]\n"
5676 "set tkPriv(deltaX) [expr {$x - [lindex $coords 0]}]\n"
5677 "set tkPriv(deltaY) [expr {$y - [lindex $coords 1]}]\n"
5678 "$w configure -sliderrelief sunken\n"
5679 "}\n"
5680 "}\n"
5681 "proc tkScaleDrag {w x y} {\n"
5682 "global tkPriv\n"
5683 "if {!$tkPriv(dragging)} {\n"
5684 "return\n"
5685 "}\n"
5686 "$w set [$w get [expr {$x-$tkPriv(deltaX)}] [expr {$y-$tkPriv(deltaY)}]]\n"
5687 "}\n"
5688 "proc tkScaleEndDrag {w} {\n"
5689 "global tkPriv\n"
5690 "set tkPriv(dragging) 0\n"
5691 "$w configure -sliderrelief raised\n"
5692 "}\n"
5693 "proc tkScaleIncrement {w dir big repeat} {\n"
5694 "global tkPriv\n"
5695 "if {![winfo exists $w]} return\n"
5696 "if {[string equal $big \"big\"]} {\n"
5697 "set inc [$w cget -bigincrement]\n"
5698 "if {$inc == 0} {\n"
5699 "set inc [expr {abs([$w cget -to] - [$w cget -from])/10.0}]\n"
5700 "}\n"
5701 "if {$inc < [$w cget -resolution]} {\n"
5702 "set inc [$w cget -resolution]\n"
5703 "}\n"
5704 "} else {\n"
5705 "set inc [$w cget -resolution]\n"
5706 "}\n"
5707 "if {([$w cget -from] > [$w cget -to]) ^ [string equal $dir \"up\"]} {\n"
5708 "set inc [expr {-$inc}]\n"
5709 "}\n"
5710 "$w set [expr {[$w get] + $inc}]\n"
5711 "if {[string equal $repeat \"again\"]} {\n"
5712 "set tkPriv(afterId) [after [$w cget -repeatinterval] \\\n"
5713 "\011\011[list tkScaleIncrement $w $dir $big again]]\n"
5714 "} elseif {[string equal $repeat \"initial\"]} {\n"
5715 "set delay [$w cget -repeatdelay]\n"
5716 "if {$delay > 0} {\n"
5717 "set tkPriv(afterId) [after $delay \\\n"
5718 "\011\011 [list tkScaleIncrement $w $dir $big again]]\n"
5719 "}\n"
5720 "}\n"
5721 "}\n"
5722 "proc tkScaleControlPress {w x y} {\n"
5723 "set el [$w identify $x $y]\n"
5724 "if {[string equal $el \"trough1\"]} {\n"
5725 "$w set [$w cget -from]\n"
5726 "} elseif {[string equal $el \"trough2\"]} {\n"
5727 "$w set [$w cget -to]\n"
5728 "}\n"
5729 "}\n"
5730 "proc tkScaleButton2Down {w x y} {\n"
5731 "global tkPriv\n"
5732 "if {[string equal [$w cget -state] \"disabled\"]} {\n"
5733 "return\n"
5734 "}\n"
5735 "$w configure -state active\n"
5736 "$w set [$w get $x $y]\n"
5737 "set tkPriv(dragging) 1\n"
5738 "set tkPriv(initValue) [$w get]\n"
5739 "set coords \"$x $y\"\n"
5740 "set tkPriv(deltaX) 0\n"
5741 "set tkPriv(deltaY) 0\n"
5742 "}\n"
5743 ;
5744 static char Et_zFile24[] =
5745 "if {[string compare $tcl_platform(platform) \"windows\"] && \\\n"
5746 "\011[string compare $tcl_platform(platform) \"macintosh\"]} {\n"
5747 "bind Scrollbar <Enter> {\n"
5748 "if {$tk_strictMotif} {\n"
5749 "set tkPriv(activeBg) [%W cget -activebackground]\n"
5750 "%W config -activebackground [%W cget -background]\n"
5751 "}\n"
5752 "%W activate [%W identify %x %y]\n"
5753 "}\n"
5754 "bind Scrollbar <Motion> {\n"
5755 "%W activate [%W identify %x %y]\n"
5756 "}\n"
5757 "bind Scrollbar <Leave> {\n"
5758 "if {$tk_strictMotif && [info exists tkPriv(activeBg)]} {\n"
5759 "%W config -activebackground $tkPriv(activeBg)\n"
5760 "}\n"
5761 "%W activate {}\n"
5762 "}\n"
5763 "bind Scrollbar <1> {\n"
5764 "tkScrollButtonDown %W %x %y\n"
5765 "}\n"
5766 "bind Scrollbar <B1-Motion> {\n"
5767 "tkScrollDrag %W %x %y\n"
5768 "}\n"
5769 "bind Scrollbar <B1-B2-Motion> {\n"
5770 "tkScrollDrag %W %x %y\n"
5771 "}\n"
5772 "bind Scrollbar <ButtonRelease-1> {\n"
5773 "tkScrollButtonUp %W %x %y\n"
5774 "}\n"
5775 "bind Scrollbar <B1-Leave> {\n"
5776 "}\n"
5777 "bind Scrollbar <B1-Enter> {\n"
5778 "}\n"
5779 "bind Scrollbar <2> {\n"
5780 "tkScrollButton2Down %W %x %y\n"
5781 "}\n"
5782 "bind Scrollbar <B1-2> {\n"
5783 "}\n"
5784 "bind Scrollbar <B2-1> {\n"
5785 "}\n"
5786 "bind Scrollbar <B2-Motion> {\n"
5787 "tkScrollDrag %W %x %y\n"
5788 "}\n"
5789 "bind Scrollbar <ButtonRelease-2> {\n"
5790 "tkScrollButtonUp %W %x %y\n"
5791 "}\n"
5792 "bind Scrollbar <B1-ButtonRelease-2> {\n"
5793 "}\n"
5794 "bind Scrollbar <B2-ButtonRelease-1> {\n"
5795 "}\n"
5796 "bind Scrollbar <B2-Leave> {\n"
5797 "}\n"
5798 "bind Scrollbar <B2-Enter> {\n"
5799 "}\n"
5800 "bind Scrollbar <Control-1> {\n"
5801 "tkScrollTopBottom %W %x %y\n"
5802 "}\n"
5803 "bind Scrollbar <Control-2> {\n"
5804 "tkScrollTopBottom %W %x %y\n"
5805 "}\n"
5806 "bind Scrollbar <Up> {\n"
5807 "tkScrollByUnits %W v -1\n"
5808 "}\n"
5809 "bind Scrollbar <Down> {\n"
5810 "tkScrollByUnits %W v 1\n"
5811 "}\n"
5812 "bind Scrollbar <Control-Up> {\n"
5813 "tkScrollByPages %W v -1\n"
5814 "}\n"
5815 "bind Scrollbar <Control-Down> {\n"
5816 "tkScrollByPages %W v 1\n"
5817 "}\n"
5818 "bind Scrollbar <Left> {\n"
5819 "tkScrollByUnits %W h -1\n"
5820 "}\n"
5821 "bind Scrollbar <Right> {\n"
5822 "tkScrollByUnits %W h 1\n"
5823 "}\n"
5824 "bind Scrollbar <Control-Left> {\n"
5825 "tkScrollByPages %W h -1\n"
5826 "}\n"
5827 "bind Scrollbar <Control-Right> {\n"
5828 "tkScrollByPages %W h 1\n"
5829 "}\n"
5830 "bind Scrollbar <Prior> {\n"
5831 "tkScrollByPages %W hv -1\n"
5832 "}\n"
5833 "bind Scrollbar <Next> {\n"
5834 "tkScrollByPages %W hv 1\n"
5835 "}\n"
5836 "bind Scrollbar <Home> {\n"
5837 "tkScrollToPos %W 0\n"
5838 "}\n"
5839 "bind Scrollbar <End> {\n"
5840 "tkScrollToPos %W 1\n"
5841 "}\n"
5842 "}\n"
5843 "proc tkScrollButtonDown {w x y} {\n"
5844 "global tkPriv\n"
5845 "set tkPriv(relief) [$w cget -activerelief]\n"
5846 "$w configure -activerelief sunken\n"
5847 "set element [$w identify $x $y]\n"
5848 "if {[string equal $element \"slider\"]} {\n"
5849 "tkScrollStartDrag $w $x $y\n"
5850 "} else {\n"
5851 "tkScrollSelect $w $element initial\n"
5852 "}\n"
5853 "}\n"
5854 "proc tkScrollButtonUp {w x y} {\n"
5855 "global tkPriv\n"
5856 "tkCancelRepeat\n"
5857 "if {[info exists tkPriv(relief)]} {\n"
5858 "$w configure -activerelief $tkPriv(relief)\n"
5859 "tkScrollEndDrag $w $x $y\n"
5860 "$w activate [$w identify $x $y]\n"
5861 "}\n"
5862 "}\n"
5863 "proc tkScrollSelect {w element repeat} {\n"
5864 "global tkPriv\n"
5865 "if {![winfo exists $w]} return\n"
5866 "switch -- $element {\n"
5867 "\"arrow1\"\011{tkScrollByUnits $w hv -1}\n"
5868 "\"trough1\"\011{tkScrollByPages $w hv -1}\n"
5869 "\"trough2\"\011{tkScrollByPages $w hv 1}\n"
5870 "\"arrow2\"\011{tkScrollByUnits $w hv 1}\n"
5871 "default\011\011{return}\n"
5872 "}\n"
5873 "if {[string equal $repeat \"again\"]} {\n"
5874 "set tkPriv(afterId) [after [$w cget -repeatinterval] \\\n"
5875 "\011\011[list tkScrollSelect $w $element again]]\n"
5876 "} elseif {[string equal $repeat \"initial\"]} {\n"
5877 "set delay [$w cget -repeatdelay]\n"
5878 "if {$delay > 0} {\n"
5879 "set tkPriv(afterId) [after $delay \\\n"
5880 "\011\011 [list tkScrollSelect $w $element again]]\n"
5881 "}\n"
5882 "}\n"
5883 "}\n"
5884 "proc tkScrollStartDrag {w x y} {\n"
5885 "global tkPriv\n"
5886 "if {[string equal [$w cget -command] \"\"]} {\n"
5887 "return\n"
5888 "}\n"
5889 "set tkPriv(pressX) $x\n"
5890 "set tkPriv(pressY) $y\n"
5891 "set tkPriv(initValues) [$w get]\n"
5892 "set iv0 [lindex $tkPriv(initValues) 0]\n"
5893 "if {[llength $tkPriv(initValues)] == 2} {\n"
5894 "set tkPriv(initPos) $iv0\n"
5895 "} elseif {$iv0 == 0} {\n"
5896 "set tkPriv(initPos) 0.0\n"
5897 "} else {\n"
5898 "set tkPriv(initPos) [expr {(double([lindex $tkPriv(initValues) 2])) \\\n"
5899 "\011\011/ [lindex $tkPriv(initValues) 0]}]\n"
5900 "}\n"
5901 "}\n"
5902 "proc tkScrollDrag {w x y} {\n"
5903 "global tkPriv\n"
5904 "if {[string equal $tkPriv(initPos) \"\"]} {\n"
5905 "return\n"
5906 "}\n"
5907 "set delta [$w delta [expr {$x - $tkPriv(pressX)}] [expr {$y - $tkPriv(pressY)}]]\n"
5908 "if {[$w cget -jump]} {\n"
5909 "if {[llength $tkPriv(initValues)] == 2} {\n"
5910 "$w set [expr {[lindex $tkPriv(initValues) 0] + $delta}] \\\n"
5911 "\011\011 [expr {[lindex $tkPriv(initValues) 1] + $delta}]\n"
5912 "} else {\n"
5913 "set delta [expr {round($delta * [lindex $tkPriv(initValues) 0])}]\n"
5914 "eval [list $w] set [lreplace $tkPriv(initValues) 2 3 \\\n"
5915 "\011\011 [expr {[lindex $tkPriv(initValues) 2] + $delta}] \\\n"
5916 "\011\011 [expr {[lindex $tkPriv(initValues) 3] + $delta}]]\n"
5917 "}\n"
5918 "} else {\n"
5919 "tkScrollToPos $w [expr {$tkPriv(initPos) + $delta}]\n"
5920 "}\n"
5921 "}\n"
5922 "proc tkScrollEndDrag {w x y} {\n"
5923 "global tkPriv\n"
5924 "if {[string equal $tkPriv(initPos) \"\"]} {\n"
5925 "return\n"
5926 "}\n"
5927 "if {[$w cget -jump]} {\n"
5928 "set delta [$w delta [expr {$x - $tkPriv(pressX)}] \\\n"
5929 "\011\011[expr {$y - $tkPriv(pressY)}]]\n"
5930 "tkScrollToPos $w [expr {$tkPriv(initPos) + $delta}]\n"
5931 "}\n"
5932 "set tkPriv(initPos) \"\"\n"
5933 "}\n"
5934 "proc tkScrollByUnits {w orient amount} {\n"
5935 "set cmd [$w cget -command]\n"
5936 "if {[string equal $cmd \"\"] || ([string first \\\n"
5937 "\011 [string index [$w cget -orient] 0] $orient] < 0)} {\n"
5938 "return\n"
5939 "}\n"
5940 "set info [$w get]\n"
5941 "if {[llength $info] == 2} {\n"
5942 "uplevel #0 $cmd scroll $amount units\n"
5943 "} else {\n"
5944 "uplevel #0 $cmd [expr {[lindex $info 2] + $amount}]\n"
5945 "}\n"
5946 "}\n"
5947 "proc tkScrollByPages {w orient amount} {\n"
5948 "set cmd [$w cget -command]\n"
5949 "if {[string equal $cmd \"\"] || ([string first \\\n"
5950 "\011 [string index [$w cget -orient] 0] $orient] < 0)} {\n"
5951 "return\n"
5952 "}\n"
5953 "set info [$w get]\n"
5954 "if {[llength $info] == 2} {\n"
5955 "uplevel #0 $cmd scroll $amount pages\n"
5956 "} else {\n"
5957 "uplevel #0 $cmd [expr {[lindex $info 2] + $amount*([lindex $info 1] - 1)}]\n"
5958 "}\n"
5959 "}\n"
5960 "proc tkScrollToPos {w pos} {\n"
5961 "set cmd [$w cget -command]\n"
5962 "if {[string equal $cmd \"\"]} {\n"
5963 "return\n"
5964 "}\n"
5965 "set info [$w get]\n"
5966 "if {[llength $info] == 2} {\n"
5967 "uplevel #0 $cmd moveto $pos\n"
5968 "} else {\n"
5969 "uplevel #0 $cmd [expr {round([lindex $info 0]*$pos)}]\n"
5970 "}\n"
5971 "}\n"
5972 "proc tkScrollTopBottom {w x y} {\n"
5973 "global tkPriv\n"
5974 "set element [$w identify $x $y]\n"
5975 "if {[string match *1 $element]} {\n"
5976 "tkScrollToPos $w 0\n"
5977 "} elseif {[string match *2 $element]} {\n"
5978 "tkScrollToPos $w 1\n"
5979 "}\n"
5980 "set tkPriv(relief) [$w cget -activerelief]\n"
5981 "}\n"
5982 "proc tkScrollButton2Down {w x y} {\n"
5983 "global tkPriv\n"
5984 "set element [$w identify $x $y]\n"
5985 "if {[string match {arrow[12]} $element]} {\n"
5986 "tkScrollButtonDown $w $x $y\n"
5987 "return\n"
5988 "}\n"
5989 "tkScrollToPos $w [$w fraction $x $y]\n"
5990 "set tkPriv(relief) [$w cget -activerelief]\n"
5991 "update idletasks\n"
5992 "$w configure -activerelief sunken\n"
5993 "$w activate slider\n"
5994 "tkScrollStartDrag $w $x $y\n"
5995 "}\n"
5996 ;
5997 static char Et_zFile25[] =
5998 "# Tcl autoload index file, version 2.0\n"
5999 "# This file is generated by the \"auto_mkindex\" command\n"
6000 "# and sourced to set up indexing information for one or\n"
6001 "# more commands. Typically each line is a command that\n"
6002 "# sets an element in the auto_index array, where the\n"
6003 "# element name is the name of a command and the value is\n"
6004 "# a script that loads the command.\n"
6005 "\n"
6006 "set auto_index(tkButtonEnter) [list source [file join $dir button.tcl]]\n"
6007 "set auto_index(tkButtonLeave) [list source [file join $dir button.tcl]]\n"
6008 "set auto_index(tkCheckRadioEnter) [list source [file join $dir button.tcl]]\n"
6009 "set auto_index(tkButtonDown) [list source [file join $dir button.tcl]]\n"
6010 "set auto_index(tkCheckRadioDown) [list source [file join $dir button.tcl]]\n"
6011 "set auto_index(tkButtonUp) [list source [file join $dir button.tcl]]\n"
6012 "set auto_index(tkButtonEnter) [list source [file join $dir button.tcl]]\n"
6013 "set auto_index(tkButtonLeave) [list source [file join $dir button.tcl]]\n"
6014 "set auto_index(tkButtonDown) [list source [file join $dir button.tcl]]\n"
6015 "set auto_index(tkButtonUp) [list source [file join $dir button.tcl]]\n"
6016 "set auto_index(tkButtonEnter) [list source [file join $dir button.tcl]]\n"
6017 "set auto_index(tkButtonLeave) [list source [file join $dir button.tcl]]\n"
6018 "set auto_index(tkButtonDown) [list source [file join $dir button.tcl]]\n"
6019 "set auto_index(tkButtonUp) [list source [file join $dir button.tcl]]\n"
6020 "set auto_index(tkButtonInvoke) [list source [file join $dir button.tcl]]\n"
6021 "set auto_index(tkCheckRadioInvoke) [list source [file join $dir button.tcl]]\n"
6022 "set auto_index(tk_dialog) [list source [file join $dir dialog.tcl]]\n"
6023 "set auto_index(tkEntryClosestGap) [list source [file join $dir entry.tcl]]\n"
6024 "set auto_index(tkEntryButton1) [list source [file join $dir entry.tcl]]\n"
6025 "set auto_index(tkEntryMouseSelect) [list source [file join $dir entry.tcl]]\n"
6026 "set auto_index(tkEntryPaste) [list source [file join $dir entry.tcl]]\n"
6027 "set auto_index(tkEntryAutoScan) [list source [file join $dir entry.tcl]]\n"
6028 "set auto_index(tkEntryKeySelect) [list source [file join $dir entry.tcl]]\n"
6029 "set auto_index(tkEntryInsert) [list source [file join $dir entry.tcl]]\n"
6030 "set auto_index(tkEntryBackspace) [list source [file join $dir entry.tcl]]\n"
6031 "set auto_index(tkEntrySeeInsert) [list source [file join $dir entry.tcl]]\n"
6032 "set auto_index(tkEntrySetCursor) [list source [file join $dir entry.tcl]]\n"
6033 "set auto_index(tkEntryTranspose) [list source [file join $dir entry.tcl]]\n"
6034 "set auto_index(tkEntryPreviousWord) [list source [file join $dir entry.tcl]]\n"
6035 "set auto_index(tkListboxBeginSelect) [list source [file join $dir listbox.tcl]]\n"
6036 "set auto_index(tkListboxMotion) [list source [file join $dir listbox.tcl]]\n"
6037 "set auto_index(tkListboxBeginExtend) [list source [file join $dir listbox.tcl]]\n"
6038 "set auto_index(tkListboxBeginToggle) [list source [file join $dir listbox.tcl]]\n"
6039 "set auto_index(tkListboxAutoScan) [list source [file join $dir listbox.tcl]]\n"
6040 "set auto_index(tkListboxUpDown) [list source [file join $dir listbox.tcl]]\n"
6041 "set auto_index(tkListboxExtendUpDown) [list source [file join $dir listbox.tcl]]\n"
6042 "set auto_index(tkListboxDataExtend) [list source [file join $dir listbox.tcl]]\n"
6043 "set auto_index(tkListboxCancel) [list source [file join $dir listbox.tcl]]\n"
6044 "set auto_index(tkListboxSelectAll) [list source [file join $dir listbox.tcl]]\n"
6045 "set auto_index(tkMbEnter) [list source [file join $dir menu.tcl]]\n"
6046 "set auto_index(tkMbLeave) [list source [file join $dir menu.tcl]]\n"
6047 "set auto_index(tkMbPost) [list source [file join $dir menu.tcl]]\n"
6048 "set auto_index(tkMenuUnpost) [list source [file join $dir menu.tcl]]\n"
6049 "set auto_index(tkMbMotion) [list source [file join $dir menu.tcl]]\n"
6050 "set auto_index(tkMbButtonUp) [list source [file join $dir menu.tcl]]\n"
6051 "set auto_index(tkMenuMotion) [list source [file join $dir menu.tcl]]\n"
6052 "set auto_index(tkMenuButtonDown) [list source [file join $dir menu.tcl]]\n"
6053 "set auto_index(tkMenuLeave) [list source [file join $dir menu.tcl]]\n"
6054 "set auto_index(tkMenuInvoke) [list source [file join $dir menu.tcl]]\n"
6055 "set auto_index(tkMenuEscape) [list source [file join $dir menu.tcl]]\n"
6056 "set auto_index(tkMenuUpArrow) [list source [file join $dir menu.tcl]]\n"
6057 "set auto_index(tkMenuDownArrow) [list source [file join $dir menu.tcl]]\n"
6058 "set auto_index(tkMenuLeftArrow) [list source [file join $dir menu.tcl]]\n"
6059 "set auto_index(tkMenuRightArrow) [list source [file join $dir menu.tcl]]\n"
6060 "set auto_index(tkMenuNextMenu) [list source [file join $dir menu.tcl]]\n"
6061 "set auto_index(tkMenuNextEntry) [list source [file join $dir menu.tcl]]\n"
6062 "set auto_index(tkMenuFind) [list source [file join $dir menu.tcl]]\n"
6063 "set auto_index(tkTraverseToMenu) [list source [file join $dir menu.tcl]]\n"
6064 "set auto_index(tkFirstMenu) [list source [file join $dir menu.tcl]]\n"
6065 "set auto_index(tkTraverseWithinMenu) [list source [file join $dir menu.tcl]]\n"
6066 "set auto_index(tkMenuFirstEntry) [list source [file join $dir menu.tcl]]\n"
6067 "set auto_index(tkMenuFindName) [list source [file join $dir menu.tcl]]\n"
6068 "set auto_index(tkPostOverPoint) [list source [file join $dir menu.tcl]]\n"
6069 "set auto_index(tkSaveGrabInfo) [list source [file join $dir menu.tcl]]\n"
6070 "set auto_index(tkRestoreOldGrab) [list source [file join $dir menu.tcl]]\n"
6071 "set auto_index(tk_menuSetFocus) [list source [file join $dir menu.tcl]]\n"
6072 "set auto_index(tkGenerateMenuSelect) [list source [file join $dir menu.tcl]]\n"
6073 "set auto_index(tk_popup) [list source [file join $dir menu.tcl]]\n"
6074 "set auto_index(tkScrollButtonDown) [list source [file join $dir scrlbar.tcl]]\n"
6075 "set auto_index(tkScrollButtonUp) [list source [file join $dir scrlbar.tcl]]\n"
6076 "set auto_index(tkScrollSelect) [list source [file join $dir scrlbar.tcl]]\n"
6077 "set auto_index(tkScrollStartDrag) [list source [file join $dir scrlbar.tcl]]\n"
6078 "set auto_index(tkScrollDrag) [list source [file join $dir scrlbar.tcl]]\n"
6079 "set auto_index(tkScrollEndDrag) [list source [file join $dir scrlbar.tcl]]\n"
6080 "set auto_index(tkScrollByUnits) [list source [file join $dir scrlbar.tcl]]\n"
6081 "set auto_index(tkScrollByPages) [list source [file join $dir scrlbar.tcl]]\n"
6082 "set auto_index(tkScrollToPos) [list source [file join $dir scrlbar.tcl]]\n"
6083 "set auto_index(tkScrollTopBottom) [list source [file join $dir scrlbar.tcl]]\n"
6084 "set auto_index(tkScrollButton2Down) [list source [file join $dir scrlbar.tcl]]\n"
6085 "set auto_index(tkTextClosestGap) [list source [file join $dir text.tcl]]\n"
6086 "set auto_index(tkTextButton1) [list source [file join $dir text.tcl]]\n"
6087 "set auto_index(tkTextSelectTo) [list source [file join $dir text.tcl]]\n"
6088 "set auto_index(tkTextKeyExtend) [list source [file join $dir text.tcl]]\n"
6089 "set auto_index(tkTextPaste) [list source [file join $dir text.tcl]]\n"
6090 "set auto_index(tkTextAutoScan) [list source [file join $dir text.tcl]]\n"
6091 "set auto_index(tkTextSetCursor) [list source [file join $dir text.tcl]]\n"
6092 "set auto_index(tkTextKeySelect) [list source [file join $dir text.tcl]]\n"
6093 "set auto_index(tkTextResetAnchor) [list source [file join $dir text.tcl]]\n"
6094 "set auto_index(tkTextInsert) [list source [file join $dir text.tcl]]\n"
6095 "set auto_index(tkTextUpDownLine) [list source [file join $dir text.tcl]]\n"
6096 "set auto_index(tkTextPrevPara) [list source [file join $dir text.tcl]]\n"
6097 "set auto_index(tkTextNextPara) [list source [file join $dir text.tcl]]\n"
6098 "set auto_index(tkTextScrollPages) [list source [file join $dir text.tcl]]\n"
6099 "set auto_index(tkTextTranspose) [list source [file join $dir text.tcl]]\n"
6100 "set auto_index(tk_textCopy) [list source [file join $dir text.tcl]]\n"
6101 "set auto_index(tk_textCut) [list source [file join $dir text.tcl]]\n"
6102 "set auto_index(tk_textPaste) [list source [file join $dir text.tcl]]\n"
6103 "set auto_index(tkTextNextPos) [list source [file join $dir text.tcl]]\n"
6104 "set auto_index(tkTextPrevPos) [list source [file join $dir text.tcl]]\n"
6105 "set auto_index(tkScreenChanged) [list source [file join $dir tk.tcl]]\n"
6106 "set auto_index(tkEventMotifBindings) [list source [file join $dir tk.tcl]]\n"
6107 "set auto_index(tkCancelRepeat) [list source [file join $dir tk.tcl]]\n"
6108 "set auto_index(tkTabToWindow) [list source [file join $dir tk.tcl]]\n"
6109 "set auto_index(bgerror) [list source [file join $dir bgerror.tcl]]\n"
6110 "set auto_index(tkScaleActivate) [list source [file join $dir scale.tcl]]\n"
6111 "set auto_index(tkScaleButtonDown) [list source [file join $dir scale.tcl]]\n"
6112 "set auto_index(tkScaleDrag) [list source [file join $dir scale.tcl]]\n"
6113 "set auto_index(tkScaleEndDrag) [list source [file join $dir scale.tcl]]\n"
6114 "set auto_index(tkScaleIncrement) [list source [file join $dir scale.tcl]]\n"
6115 "set auto_index(tkScaleControlPress) [list source [file join $dir scale.tcl]]\n"
6116 "set auto_index(tkScaleButton2Down) [list source [file join $dir scale.tcl]]\n"
6117 "set auto_index(tk_optionMenu) [list source [file join $dir optMenu.tcl]]\n"
6118 "set auto_index(tkTearOffMenu) [list source [file join $dir tearoff.tcl]]\n"
6119 "set auto_index(tkMenuDup) [list source [file join $dir tearoff.tcl]]\n"
6120 "set auto_index(tk_menuBar) [list source [file join $dir obsolete.tcl]]\n"
6121 "set auto_index(tk_bindForTraversal) [list source [file join $dir obsolete.tcl]]\n"
6122 "set auto_index(tk_focusNext) [list source [file join $dir focus.tcl]]\n"
6123 "set auto_index(tk_focusPrev) [list source [file join $dir focus.tcl]]\n"
6124 "set auto_index(tkFocusOK) [list source [file join $dir focus.tcl]]\n"
6125 "set auto_index(tk_focusFollowsMouse) [list source [file join $dir focus.tcl]]\n"
6126 "set auto_index(tkConsoleInit) [list source [file join $dir console.tcl]]\n"
6127 "set auto_index(tkConsoleSource) [list source [file join $dir console.tcl]]\n"
6128 "set auto_index(tkConsoleInvoke) [list source [file join $dir console.tcl]]\n"
6129 "set auto_index(tkConsoleHistory) [list source [file join $dir console.tcl]]\n"
6130 "set auto_index(tkConsolePrompt) [list source [file join $dir console.tcl]]\n"
6131 "set auto_index(tkConsoleBind) [list source [file join $dir console.tcl]]\n"
6132 "set auto_index(tkConsoleInsert) [list source [file join $dir console.tcl]]\n"
6133 "set auto_index(tkConsoleOutput) [list source [file join $dir console.tcl]]\n"
6134 "set auto_index(tkConsoleExit) [list source [file join $dir console.tcl]]\n"
6135 "set auto_index(tkConsoleAbout) [list source [file join $dir console.tcl]]\n"
6136 "set auto_index(tk_setPalette) [list source [file join $dir palette.tcl]]\n"
6137 "set auto_index(tkRecolorTree) [list source [file join $dir palette.tcl]]\n"
6138 "set auto_index(tkDarken) [list source [file join $dir palette.tcl]]\n"
6139 "set auto_index(tk_bisque) [list source [file join $dir palette.tcl]]\n"
6140 "set auto_index(tkColorDialog) [list source [file join $dir clrpick.tcl]]\n"
6141 "set auto_index(tkColorDialog_InitValues) [list source [file join $dir clrpick.tcl]]\n"
6142 "set auto_index(tkColorDialog_Config) [list source [file join $dir clrpick.tcl]]\n"
6143 "set auto_index(tkColorDialog_BuildDialog) [list source [file join $dir clrpick.tcl]]\n"
6144 "set auto_index(tkColorDialog_SetRGBValue) [list source [file join $dir clrpick.tcl]]\n"
6145 "set auto_index(tkColorDialog_XToRgb) [list source [file join $dir clrpick.tcl]]\n"
6146 "set auto_index(tkColorDialog_RgbToX) [list source [file join $dir clrpick.tcl]]\n"
6147 "set auto_index(tkColorDialog_DrawColorScale) [list source [file join $dir clrpick.tcl]]\n"
6148 "set auto_index(tkColorDialog_CreateSelector) [list source [file join $dir clrpick.tcl]]\n"
6149 "set auto_index(tkColorDialog_RedrawFinalColor) [list source [file join $dir clrpick.tcl]]\n"
6150 "set auto_index(tkColorDialog_RedrawColorBars) [list source [file join $dir clrpick.tcl]]\n"
6151 "set auto_index(tkColorDialog_StartMove) [list source [file join $dir clrpick.tcl]]\n"
6152 "set auto_index(tkColorDialog_MoveSelector) [list source [file join $dir clrpick.tcl]]\n"
6153 "set auto_index(tkColorDialog_ReleaseMouse) [list source [file join $dir clrpick.tcl]]\n"
6154 "set auto_index(tkColorDialog_ResizeColorBars) [list source [file join $dir clrpick.tcl]]\n"
6155 "set auto_index(tkColorDialog_HandleSelEntry) [list source [file join $dir clrpick.tcl]]\n"
6156 "set auto_index(tkColorDialog_HandleRGBEntry) [list source [file join $dir clrpick.tcl]]\n"
6157 "set auto_index(tkColorDialog_EnterColorBar) [list source [file join $dir clrpick.tcl]]\n"
6158 "set auto_index(tkColorDialog_LeaveColorBar) [list source [file join $dir clrpick.tcl]]\n"
6159 "set auto_index(tkColorDialog_OkCmd) [list source [file join $dir clrpick.tcl]]\n"
6160 "set auto_index(tkColorDialog_CancelCmd) [list source [file join $dir clrpick.tcl]]\n"
6161 "set auto_index(tclParseConfigSpec) [list source [file join $dir comdlg.tcl]]\n"
6162 "set auto_index(tclListValidFlags) [list source [file join $dir comdlg.tcl]]\n"
6163 "set auto_index(tclSortNoCase) [list source [file join $dir comdlg.tcl]]\n"
6164 "set auto_index(tclVerifyInteger) [list source [file join $dir comdlg.tcl]]\n"
6165 "set auto_index(tkFocusGroup_Create) [list source [file join $dir comdlg.tcl]]\n"
6166 "set auto_index(tkFocusGroup_BindIn) [list source [file join $dir comdlg.tcl]]\n"
6167 "set auto_index(tkFocusGroup_BindOut) [list source [file join $dir comdlg.tcl]]\n"
6168 "set auto_index(tkFocusGroup_Destroy) [list source [file join $dir comdlg.tcl]]\n"
6169 "set auto_index(tkFocusGroup_In) [list source [file join $dir comdlg.tcl]]\n"
6170 "set auto_index(tkFocusGroup_Out) [list source [file join $dir comdlg.tcl]]\n"
6171 "set auto_index(tkFDGetFileTypes) [list source [file join $dir comdlg.tcl]]\n"
6172 "set auto_index(::safe::loadTk) [list source [file join $dir safetk.tcl]]\n"
6173 "set auto_index(::safe::TkInit) [list source [file join $dir safetk.tcl]]\n"
6174 "set auto_index(::safe::allowTk) [list source [file join $dir safetk.tcl]]\n"
6175 "set auto_index(::safe::tkTopLevel) [list source [file join $dir safetk.tcl]]\n"
6176 "set auto_index(tkMessageBox) [list source [file join $dir msgbox.tcl]]\n"
6177 "set auto_index(tkIconList) [list source [file join $dir tkfbox.tcl]]\n"
6178 "set auto_index(tkIconList_Config) [list source [file join $dir tkfbox.tcl]]\n"
6179 "set auto_index(tkIconList_Create) [list source [file join $dir tkfbox.tcl]]\n"
6180 "set auto_index(tkIconList_AutoScan) [list source [file join $dir tkfbox.tcl]]\n"
6181 "set auto_index(tkIconList_DeleteAll) [list source [file join $dir tkfbox.tcl]]\n"
6182 "set auto_index(tkIconList_Add) [list source [file join $dir tkfbox.tcl]]\n"
6183 "set auto_index(tkIconList_Arrange) [list source [file join $dir tkfbox.tcl]]\n"
6184 "set auto_index(tkIconList_Invoke) [list source [file join $dir tkfbox.tcl]]\n"
6185 "set auto_index(tkIconList_See) [list source [file join $dir tkfbox.tcl]]\n"
6186 "set auto_index(tkIconList_SelectAtXY) [list source [file join $dir tkfbox.tcl]]\n"
6187 "set auto_index(tkIconList_Select) [list source [file join $dir tkfbox.tcl]]\n"
6188 "set auto_index(tkIconList_Unselect) [list source [file join $dir tkfbox.tcl]]\n"
6189 "set auto_index(tkIconList_Get) [list source [file join $dir tkfbox.tcl]]\n"
6190 "set auto_index(tkIconList_Btn1) [list source [file join $dir tkfbox.tcl]]\n"
6191 "set auto_index(tkIconList_Motion1) [list source [file join $dir tkfbox.tcl]]\n"
6192 "set auto_index(tkIconList_Double1) [list source [file join $dir tkfbox.tcl]]\n"
6193 "set auto_index(tkIconList_ReturnKey) [list source [file join $dir tkfbox.tcl]]\n"
6194 "set auto_index(tkIconList_Leave1) [list source [file join $dir tkfbox.tcl]]\n"
6195 "set auto_index(tkIconList_FocusIn) [list source [file join $dir tkfbox.tcl]]\n"
6196 "set auto_index(tkIconList_UpDown) [list source [file join $dir tkfbox.tcl]]\n"
6197 "set auto_index(tkIconList_LeftRight) [list source [file join $dir tkfbox.tcl]]\n"
6198 "set auto_index(tkIconList_KeyPress) [list source [file join $dir tkfbox.tcl]]\n"
6199 "set auto_index(tkIconList_Goto) [list source [file join $dir tkfbox.tcl]]\n"
6200 "set auto_index(tkIconList_Reset) [list source [file join $dir tkfbox.tcl]]\n"
6201 "set auto_index(::tk::dialog::file::tkFDialog) [list source [file join $dir tkfbox.tcl]]\n"
6202 "set auto_index(::tk::dialog::file::Config) [list source [file join $dir tkfbox.tcl]]\n"
6203 "set auto_index(::tk::dialog::file::Create) [list source [file join $dir tkfbox.tcl]]\n"
6204 "set auto_index(::tk::dialog::file::UpdateWhenIdle) [list source [file join $dir tkfbox.tcl]]\n"
6205 "set auto_index(::tk::dialog::file::Update) [list source [file join $dir tkfbox.tcl]]\n"
6206 "set auto_index(::tk::dialog::file::SetPathSilently) [list source [file join $dir tkfbox.tcl]]\n"
6207 "set auto_index(::tk::dialog::file::SetPath) [list source [file join $dir tkfbox.tcl]]\n"
6208 "set auto_index(::tk::dialog::file::SetFilter) [list source [file join $dir tkfbox.tcl]]\n"
6209 "set auto_index(tkFDialogResolveFile) [list source [file join $dir tkfbox.tcl]]\n"
6210 "set auto_index(::tk::dialog::file::EntFocusIn) [list source [file join $dir tkfbox.tcl]]\n"
6211 "set auto_index(::tk::dialog::file::EntFocusOut) [list source [file join $dir tkfbox.tcl]]\n"
6212 "set auto_index(::tk::dialog::file::ActivateEnt) [list source [file join $dir tkfbox.tcl]]\n"
6213 "set auto_index(::tk::dialog::file::InvokeBtn) [list source [file join $dir tkfbox.tcl]]\n"
6214 "set auto_index(::tk::dialog::file::UpDirCmd) [list source [file join $dir tkfbox.tcl]]\n"
6215 "set auto_index(::tk::dialog::file::JoinFile) [list source [file join $dir tkfbox.tcl]]\n"
6216 "set auto_index(::tk::dialog::file::OkCmd) [list source [file join $dir tkfbox.tcl]]\n"
6217 "set auto_index(::tk::dialog::file::CancelCmd) [list source [file join $dir tkfbox.tcl]]\n"
6218 "set auto_index(::tk::dialog::file::ListBrowse) [list source [file join $dir tkfbox.tcl]]\n"
6219 "set auto_index(::tk::dialog::file::ListInvoke) [list source [file join $dir tkfbox.tcl]]\n"
6220 "set auto_index(::tk::dialog::file::Done) [list source [file join $dir tkfbox.tcl]]\n"
6221 "set auto_index(tkMotifFDialog) [list source [file join $dir xmfbox.tcl]]\n"
6222 "set auto_index(tkMotifFDialog_Config) [list source [file join $dir xmfbox.tcl]]\n"
6223 "set auto_index(tkMotifFDialog_Create) [list source [file join $dir xmfbox.tcl]]\n"
6224 "set auto_index(tkMotifFDialog_MakeSList) [list source [file join $dir xmfbox.tcl]]\n"
6225 "set auto_index(tkMotifFDialog_BrowseDList) [list source [file join $dir xmfbox.tcl]]\n"
6226 "set auto_index(tkMotifFDialog_ActivateDList) [list source [file join $dir xmfbox.tcl]]\n"
6227 "set auto_index(tkMotifFDialog_BrowseFList) [list source [file join $dir xmfbox.tcl]]\n"
6228 "set auto_index(tkMotifFDialog_ActivateFList) [list source [file join $dir xmfbox.tcl]]\n"
6229 "set auto_index(tkMotifFDialog_ActivateFEnt) [list source [file join $dir xmfbox.tcl]]\n"
6230 "set auto_index(tkMotifFDialog_InterpFilter) [list source [file join $dir xmfbox.tcl]]\n"
6231 "set auto_index(tkMotifFDialog_ActivateSEnt) [list source [file join $dir xmfbox.tcl]]\n"
6232 "set auto_index(tkMotifFDialog_OkCmd) [list source [file join $dir xmfbox.tcl]]\n"
6233 "set auto_index(tkMotifFDialog_FilterCmd) [list source [file join $dir xmfbox.tcl]]\n"
6234 "set auto_index(tkMotifFDialog_CancelCmd) [list source [file join $dir xmfbox.tcl]]\n"
6235 "set auto_index(tkMotifFDialog_Update) [list source [file join $dir xmfbox.tcl]]\n"
6236 "set auto_index(tkMotifFDialog_LoadFiles) [list source [file join $dir xmfbox.tcl]]\n"
6237 "set auto_index(tkListBoxKeyAccel_Set) [list source [file join $dir xmfbox.tcl]]\n"
6238 "set auto_index(tkListBoxKeyAccel_Unset) [list source [file join $dir xmfbox.tcl]]\n"
6239 "set auto_index(tkListBoxKeyAccel_Key) [list source [file join $dir xmfbox.tcl]]\n"
6240 "set auto_index(tkListBoxKeyAccel_Goto) [list source [file join $dir xmfbox.tcl]]\n"
6241 "set auto_index(tkListBoxKeyAccel_Reset) [list source [file join $dir xmfbox.tcl]]\n"
6242 "set auto_index(::tk::dialog::file::chooseDir::tkChooseDirectory) [list source [file join $dir choosedir.tcl]]\n"
6243 ;
6244 static char Et_zFile26[] =
6245 "proc tkTearOffMenu {w {x 0} {y 0}} {\n"
6246 "if {$x == 0} {\n"
6247 "set x [winfo rootx $w]\n"
6248 "}\n"
6249 "if {$y == 0} {\n"
6250 "set y [winfo rooty $w]\n"
6251 "}\n"
6252 "set parent [winfo parent $w]\n"
6253 "while {[string compare [winfo toplevel $parent] $parent] \\\n"
6254 "\011 || [string equal [winfo class $parent] \"Menu\"]} {\n"
6255 "set parent [winfo parent $parent]\n"
6256 "}\n"
6257 "if {[string equal $parent \".\"]} {\n"
6258 "set parent \"\"\n"
6259 "}\n"
6260 "for {set i 1} 1 {incr i} {\n"
6261 "set menu $parent.tearoff$i\n"
6262 "if {![winfo exists $menu]} {\n"
6263 "break\n"
6264 "}\n"
6265 "}\n"
6266 "$w clone $menu tearoff\n"
6267 "set parent [winfo parent $w]\n"
6268 "if {[string compare [$menu cget -title] \"\"]} {\n"
6269 "wm title $menu [$menu cget -title]\n"
6270 "} else {\n"
6271 "switch [winfo class $parent] {\n"
6272 "Menubutton {\n"
6273 "wm title $menu [$parent cget -text]\n"
6274 "}\n"
6275 "Menu {\n"
6276 "wm title $menu [$parent entrycget active -label]\n"
6277 "}\n"
6278 "}\n"
6279 "}\n"
6280 "$menu post $x $y\n"
6281 "if {[winfo exists $menu] == 0} {\n"
6282 "return \"\"\n"
6283 "}\n"
6284 "bind $menu <Enter> {\n"
6285 "set tkPriv(focus) %W\n"
6286 "}\n"
6287 "set cmd [$w cget -tearoffcommand]\n"
6288 "if {[string compare $cmd \"\"]} {\n"
6289 "uplevel #0 $cmd [list $w $menu]\n"
6290 "}\n"
6291 "return $menu\n"
6292 "}\n"
6293 "proc tkMenuDup {src dst type} {\n"
6294 "set cmd [list menu $dst -type $type]\n"
6295 "foreach option [$src configure] {\n"
6296 "if {[llength $option] == 2} {\n"
6297 "continue\n"
6298 "}\n"
6299 "if {[string equal [lindex $option 0] \"-type\"]} {\n"
6300 "continue\n"
6301 "}\n"
6302 "lappend cmd [lindex $option 0] [lindex $option 4]\n"
6303 "}\n"
6304 "eval $cmd\n"
6305 "set last [$src index last]\n"
6306 "if {[string equal $last \"none\"]} {\n"
6307 "return\n"
6308 "}\n"
6309 "for {set i [$src cget -tearoff]} {$i <= $last} {incr i} {\n"
6310 "set cmd [list $dst add [$src type $i]]\n"
6311 "foreach option [$src entryconfigure $i] {\n"
6312 "lappend cmd [lindex $option 0] [lindex $option 4]\n"
6313 "}\n"
6314 "eval $cmd\n"
6315 "}\n"
6316 "set tags [bindtags $src]\n"
6317 "set srcLen [string length $src]\n"
6318 "while {[set index [string first $src $tags]] != -1} {\n"
6319 "append x [string range $tags 0 [expr {$index - 1}]]$dst\n"
6320 "set tags [string range $tags [expr {$index + $srcLen}] end]\n"
6321 "}\n"
6322 "append x $tags\n"
6323 "bindtags $dst $x\n"
6324 "foreach event [bind $src] {\n"
6325 "unset x\n"
6326 "set script [bind $src $event]\n"
6327 "set eventLen [string length $event]\n"
6328 "while {[set index [string first $event $script]] != -1} {\n"
6329 "append x [string range $script 0 [expr {$index - 1}]]\n"
6330 "append x $dst\n"
6331 "set script [string range $script [expr {$index + $eventLen}] end]\n"
6332 "}\n"
6333 "append x $script\n"
6334 "bind $dst $event $x\n"
6335 "}\n"
6336 "}\n"
6337 ;
6338 static char Et_zFile27[] =
6339 "bind Text <1> {\n"
6340 "tkTextButton1 %W %x %y\n"
6341 "%W tag remove sel 0.0 end\n"
6342 "}\n"
6343 "bind Text <B1-Motion> {\n"
6344 "set tkPriv(x) %x\n"
6345 "set tkPriv(y) %y\n"
6346 "tkTextSelectTo %W %x %y\n"
6347 "}\n"
6348 "bind Text <Double-1> {\n"
6349 "set tkPriv(selectMode) word\n"
6350 "tkTextSelectTo %W %x %y\n"
6351 "catch {%W mark set insert sel.last}\n"
6352 "catch {%W mark set anchor sel.first}\n"
6353 "}\n"
6354 "bind Text <Triple-1> {\n"
6355 "set tkPriv(selectMode) line\n"
6356 "tkTextSelectTo %W %x %y\n"
6357 "catch {%W mark set insert sel.last}\n"
6358 "catch {%W mark set anchor sel.first}\n"
6359 "}\n"
6360 "bind Text <Shift-1> {\n"
6361 "tkTextResetAnchor %W @%x,%y\n"
6362 "set tkPriv(selectMode) char\n"
6363 "tkTextSelectTo %W %x %y\n"
6364 "}\n"
6365 "bind Text <Double-Shift-1>\011{\n"
6366 "set tkPriv(selectMode) word\n"
6367 "tkTextSelectTo %W %x %y 1\n"
6368 "}\n"
6369 "bind Text <Triple-Shift-1>\011{\n"
6370 "set tkPriv(selectMode) line\n"
6371 "tkTextSelectTo %W %x %y\n"
6372 "}\n"
6373 "bind Text <B1-Leave> {\n"
6374 "set tkPriv(x) %x\n"
6375 "set tkPriv(y) %y\n"
6376 "tkTextAutoScan %W\n"
6377 "}\n"
6378 "bind Text <B1-Enter> {\n"
6379 "tkCancelRepeat\n"
6380 "}\n"
6381 "bind Text <ButtonRelease-1> {\n"
6382 "tkCancelRepeat\n"
6383 "}\n"
6384 "bind Text <Control-1> {\n"
6385 "%W mark set insert @%x,%y\n"
6386 "}\n"
6387 "bind Text <Left> {\n"
6388 "tkTextSetCursor %W insert-1c\n"
6389 "}\n"
6390 "bind Text <Right> {\n"
6391 "tkTextSetCursor %W insert+1c\n"
6392 "}\n"
6393 "bind Text <Up> {\n"
6394 "tkTextSetCursor %W [tkTextUpDownLine %W -1]\n"
6395 "}\n"
6396 "bind Text <Down> {\n"
6397 "tkTextSetCursor %W [tkTextUpDownLine %W 1]\n"
6398 "}\n"
6399 "bind Text <Shift-Left> {\n"
6400 "tkTextKeySelect %W [%W index {insert - 1c}]\n"
6401 "}\n"
6402 "bind Text <Shift-Right> {\n"
6403 "tkTextKeySelect %W [%W index {insert + 1c}]\n"
6404 "}\n"
6405 "bind Text <Shift-Up> {\n"
6406 "tkTextKeySelect %W [tkTextUpDownLine %W -1]\n"
6407 "}\n"
6408 "bind Text <Shift-Down> {\n"
6409 "tkTextKeySelect %W [tkTextUpDownLine %W 1]\n"
6410 "}\n"
6411 "bind Text <Control-Left> {\n"
6412 "tkTextSetCursor %W [tkTextPrevPos %W insert tcl_startOfPreviousWord]\n"
6413 "}\n"
6414 "bind Text <Control-Right> {\n"
6415 "tkTextSetCursor %W [tkTextNextWord %W insert]\n"
6416 "}\n"
6417 "bind Text <Control-Up> {\n"
6418 "tkTextSetCursor %W [tkTextPrevPara %W insert]\n"
6419 "}\n"
6420 "bind Text <Control-Down> {\n"
6421 "tkTextSetCursor %W [tkTextNextPara %W insert]\n"
6422 "}\n"
6423 "bind Text <Shift-Control-Left> {\n"
6424 "tkTextKeySelect %W [tkTextPrevPos %W insert tcl_startOfPreviousWord]\n"
6425 "}\n"
6426 "bind Text <Shift-Control-Right> {\n"
6427 "tkTextKeySelect %W [tkTextNextWord %W insert]\n"
6428 "}\n"
6429 "bind Text <Shift-Control-Up> {\n"
6430 "tkTextKeySelect %W [tkTextPrevPara %W insert]\n"
6431 "}\n"
6432 "bind Text <Shift-Control-Down> {\n"
6433 "tkTextKeySelect %W [tkTextNextPara %W insert]\n"
6434 "}\n"
6435 "bind Text <Prior> {\n"
6436 "tkTextSetCursor %W [tkTextScrollPages %W -1]\n"
6437 "}\n"
6438 "bind Text <Shift-Prior> {\n"
6439 "tkTextKeySelect %W [tkTextScrollPages %W -1]\n"
6440 "}\n"
6441 "bind Text <Next> {\n"
6442 "tkTextSetCursor %W [tkTextScrollPages %W 1]\n"
6443 "}\n"
6444 "bind Text <Shift-Next> {\n"
6445 "tkTextKeySelect %W [tkTextScrollPages %W 1]\n"
6446 "}\n"
6447 "bind Text <Control-Prior> {\n"
6448 "%W xview scroll -1 page\n"
6449 "}\n"
6450 "bind Text <Control-Next> {\n"
6451 "%W xview scroll 1 page\n"
6452 "}\n"
6453 "bind Text <Home> {\n"
6454 "tkTextSetCursor %W {insert linestart}\n"
6455 "}\n"
6456 "bind Text <Shift-Home> {\n"
6457 "tkTextKeySelect %W {insert linestart}\n"
6458 "}\n"
6459 "bind Text <End> {\n"
6460 "tkTextSetCursor %W {insert lineend}\n"
6461 "}\n"
6462 "bind Text <Shift-End> {\n"
6463 "tkTextKeySelect %W {insert lineend}\n"
6464 "}\n"
6465 "bind Text <Control-Home> {\n"
6466 "tkTextSetCursor %W 1.0\n"
6467 "}\n"
6468 "bind Text <Control-Shift-Home> {\n"
6469 "tkTextKeySelect %W 1.0\n"
6470 "}\n"
6471 "bind Text <Control-End> {\n"
6472 "tkTextSetCursor %W {end - 1 char}\n"
6473 "}\n"
6474 "bind Text <Control-Shift-End> {\n"
6475 "tkTextKeySelect %W {end - 1 char}\n"
6476 "}\n"
6477 "bind Text <Tab> {\n"
6478 "tkTextInsert %W \\t\n"
6479 "focus %W\n"
6480 "break\n"
6481 "}\n"
6482 "bind Text <Shift-Tab> {\n"
6483 "break\n"
6484 "}\n"
6485 "bind Text <Control-Tab> {\n"
6486 "focus [tk_focusNext %W]\n"
6487 "}\n"
6488 "bind Text <Control-Shift-Tab> {\n"
6489 "focus [tk_focusPrev %W]\n"
6490 "}\n"
6491 "bind Text <Control-i> {\n"
6492 "tkTextInsert %W \\t\n"
6493 "}\n"
6494 "bind Text <Return> {\n"
6495 "tkTextInsert %W \\n\n"
6496 "}\n"
6497 "bind Text <Delete> {\n"
6498 "if {[string compare [%W tag nextrange sel 1.0 end] \"\"]} {\n"
6499 "%W delete sel.first sel.last\n"
6500 "} else {\n"
6501 "%W delete insert\n"
6502 "%W see insert\n"
6503 "}\n"
6504 "}\n"
6505 "bind Text <BackSpace> {\n"
6506 "if {[string compare [%W tag nextrange sel 1.0 end] \"\"]} {\n"
6507 "%W delete sel.first sel.last\n"
6508 "} elseif {[%W compare insert != 1.0]} {\n"
6509 "%W delete insert-1c\n"
6510 "%W see insert\n"
6511 "}\n"
6512 "}\n"
6513 "bind Text <Control-space> {\n"
6514 "%W mark set anchor insert\n"
6515 "}\n"
6516 "bind Text <Select> {\n"
6517 "%W mark set anchor insert\n"
6518 "}\n"
6519 "bind Text <Control-Shift-space> {\n"
6520 "set tkPriv(selectMode) char\n"
6521 "tkTextKeyExtend %W insert\n"
6522 "}\n"
6523 "bind Text <Shift-Select> {\n"
6524 "set tkPriv(selectMode) char\n"
6525 "tkTextKeyExtend %W insert\n"
6526 "}\n"
6527 "bind Text <Control-slash> {\n"
6528 "%W tag add sel 1.0 end\n"
6529 "}\n"
6530 "bind Text <Control-backslash> {\n"
6531 "%W tag remove sel 1.0 end\n"
6532 "}\n"
6533 "bind Text <<Cut>> {\n"
6534 "tk_textCut %W\n"
6535 "}\n"
6536 "bind Text <<Copy>> {\n"
6537 "tk_textCopy %W\n"
6538 "}\n"
6539 "bind Text <<Paste>> {\n"
6540 "tk_textPaste %W\n"
6541 "}\n"
6542 "bind Text <<Clear>> {\n"
6543 "catch {%W delete sel.first sel.last}\n"
6544 "}\n"
6545 "bind Text <<PasteSelection>> {\n"
6546 "if {!$tkPriv(mouseMoved) || $tk_strictMotif} {\n"
6547 "tkTextPaste %W %x %y\n"
6548 "}\n"
6549 "}\n"
6550 "bind Text <Insert> {\n"
6551 "catch {tkTextInsert %W [selection get -displayof %W]}\n"
6552 "}\n"
6553 "bind Text <KeyPress> {\n"
6554 "tkTextInsert %W %A\n"
6555 "}\n"
6556 "bind Text <Alt-KeyPress> {# nothing }\n"
6557 "bind Text <Meta-KeyPress> {# nothing}\n"
6558 "bind Text <Control-KeyPress> {# nothing}\n"
6559 "bind Text <Escape> {# nothing}\n"
6560 "bind Text <KP_Enter> {# nothing}\n"
6561 "if {[string equal $tcl_platform(platform) \"macintosh\"]} {\n"
6562 "bind Text <Command-KeyPress> {# nothing}\n"
6563 "}\n"
6564 "bind Text <Control-a> {\n"
6565 "if {!$tk_strictMotif} {\n"
6566 "tkTextSetCursor %W {insert linestart}\n"
6567 "}\n"
6568 "}\n"
6569 "bind Text <Control-b> {\n"
6570 "if {!$tk_strictMotif} {\n"
6571 "tkTextSetCursor %W insert-1c\n"
6572 "}\n"
6573 "}\n"
6574 "bind Text <Control-d> {\n"
6575 "if {!$tk_strictMotif} {\n"
6576 "%W delete insert\n"
6577 "}\n"
6578 "}\n"
6579 "bind Text <Control-e> {\n"
6580 "if {!$tk_strictMotif} {\n"
6581 "tkTextSetCursor %W {insert lineend}\n"
6582 "}\n"
6583 "}\n"
6584 "bind Text <Control-f> {\n"
6585 "if {!$tk_strictMotif} {\n"
6586 "tkTextSetCursor %W insert+1c\n"
6587 "}\n"
6588 "}\n"
6589 "bind Text <Control-k> {\n"
6590 "if {!$tk_strictMotif} {\n"
6591 "if {[%W compare insert == {insert lineend}]} {\n"
6592 "%W delete insert\n"
6593 "} else {\n"
6594 "%W delete insert {insert lineend}\n"
6595 "}\n"
6596 "}\n"
6597 "}\n"
6598 "bind Text <Control-n> {\n"
6599 "if {!$tk_strictMotif} {\n"
6600 "tkTextSetCursor %W [tkTextUpDownLine %W 1]\n"
6601 "}\n"
6602 "}\n"
6603 "bind Text <Control-o> {\n"
6604 "if {!$tk_strictMotif} {\n"
6605 "%W insert insert \\n\n"
6606 "%W mark set insert insert-1c\n"
6607 "}\n"
6608 "}\n"
6609 "bind Text <Control-p> {\n"
6610 "if {!$tk_strictMotif} {\n"
6611 "tkTextSetCursor %W [tkTextUpDownLine %W -1]\n"
6612 "}\n"
6613 "}\n"
6614 "bind Text <Control-t> {\n"
6615 "if {!$tk_strictMotif} {\n"
6616 "tkTextTranspose %W\n"
6617 "}\n"
6618 "}\n"
6619 "if {[string compare $tcl_platform(platform) \"windows\"]} {\n"
6620 "bind Text <Control-v> {\n"
6621 "if {!$tk_strictMotif} {\n"
6622 "tkTextScrollPages %W 1\n"
6623 "}\n"
6624 "}\n"
6625 "}\n"
6626 "bind Text <Meta-b> {\n"
6627 "if {!$tk_strictMotif} {\n"
6628 "tkTextSetCursor %W [tkTextPrevPos %W insert tcl_startOfPreviousWord]\n"
6629 "}\n"
6630 "}\n"
6631 "bind Text <Meta-d> {\n"
6632 "if {!$tk_strictMotif} {\n"
6633 "%W delete insert [tkTextNextWord %W insert]\n"
6634 "}\n"
6635 "}\n"
6636 "bind Text <Meta-f> {\n"
6637 "if {!$tk_strictMotif} {\n"
6638 "tkTextSetCursor %W [tkTextNextWord %W insert]\n"
6639 "}\n"
6640 "}\n"
6641 "bind Text <Meta-less> {\n"
6642 "if {!$tk_strictMotif} {\n"
6643 "tkTextSetCursor %W 1.0\n"
6644 "}\n"
6645 "}\n"
6646 "bind Text <Meta-greater> {\n"
6647 "if {!$tk_strictMotif} {\n"
6648 "tkTextSetCursor %W end-1c\n"
6649 "}\n"
6650 "}\n"
6651 "bind Text <Meta-BackSpace> {\n"
6652 "if {!$tk_strictMotif} {\n"
6653 "%W delete [tkTextPrevPos %W insert tcl_startOfPreviousWord] insert\n"
6654 "}\n"
6655 "}\n"
6656 "bind Text <Meta-Delete> {\n"
6657 "if {!$tk_strictMotif} {\n"
6658 "%W delete [tkTextPrevPos %W insert tcl_startOfPreviousWord] insert\n"
6659 "}\n"
6660 "}\n"
6661 "if {[string equal $tcl_platform(platform) \"macintosh\"]} {\n"
6662 "bind Text <FocusIn> {\n"
6663 "%W tag configure sel -borderwidth 0\n"
6664 "%W configure -selectbackground systemHighlight -selectforeground systemHighlightText\n"
6665 "}\n"
6666 "bind Text <FocusOut> {\n"
6667 "%W tag configure sel -borderwidth 1\n"
6668 "%W configure -selectbackground white -selectforeground black\n"
6669 "}\n"
6670 "bind Text <Option-Left> {\n"
6671 "tkTextSetCursor %W [tkTextPrevPos %W insert tcl_startOfPreviousWord]\n"
6672 "}\n"
6673 "bind Text <Option-Right> {\n"
6674 "tkTextSetCursor %W [tkTextNextWord %W insert]\n"
6675 "}\n"
6676 "bind Text <Option-Up> {\n"
6677 "tkTextSetCursor %W [tkTextPrevPara %W insert]\n"
6678 "}\n"
6679 "bind Text <Option-Down> {\n"
6680 "tkTextSetCursor %W [tkTextNextPara %W insert]\n"
6681 "}\n"
6682 "bind Text <Shift-Option-Left> {\n"
6683 "tkTextKeySelect %W [tkTextPrevPos %W insert tcl_startOfPreviousWord]\n"
6684 "}\n"
6685 "bind Text <Shift-Option-Right> {\n"
6686 "tkTextKeySelect %W [tkTextNextWord %W insert]\n"
6687 "}\n"
6688 "bind Text <Shift-Option-Up> {\n"
6689 "tkTextKeySelect %W [tkTextPrevPara %W insert]\n"
6690 "}\n"
6691 "bind Text <Shift-Option-Down> {\n"
6692 "tkTextKeySelect %W [tkTextNextPara %W insert]\n"
6693 "}\n"
6694 "}\n"
6695 "bind Text <Control-h> {\n"
6696 "if {!$tk_strictMotif} {\n"
6697 "if {[%W compare insert != 1.0]} {\n"
6698 "%W delete insert-1c\n"
6699 "%W see insert\n"
6700 "}\n"
6701 "}\n"
6702 "}\n"
6703 "bind Text <2> {\n"
6704 "if {!$tk_strictMotif} {\n"
6705 "%W scan mark %x %y\n"
6706 "set tkPriv(x) %x\n"
6707 "set tkPriv(y) %y\n"
6708 "set tkPriv(mouseMoved) 0\n"
6709 "}\n"
6710 "}\n"
6711 "bind Text <B2-Motion> {\n"
6712 "if {!$tk_strictMotif} {\n"
6713 "if {(%x != $tkPriv(x)) || (%y != $tkPriv(y))} {\n"
6714 "set tkPriv(mouseMoved) 1\n"
6715 "}\n"
6716 "if {$tkPriv(mouseMoved)} {\n"
6717 "%W scan dragto %x %y\n"
6718 "}\n"
6719 "}\n"
6720 "}\n"
6721 "set tkPriv(prevPos) {}\n"
6722 "bind Text <MouseWheel> {\n"
6723 "%W yview scroll [expr {- (%D / 120) * 4}] units\n"
6724 "}\n"
6725 "if {[string equal \"unix\" $tcl_platform(platform)]} {\n"
6726 "bind Text <4> {\n"
6727 "if {!$tk_strictMotif} {\n"
6728 "%W yview scroll -5 units\n"
6729 "}\n"
6730 "}\n"
6731 "bind Text <5> {\n"
6732 "if {!$tk_strictMotif} {\n"
6733 "%W yview scroll 5 units\n"
6734 "}\n"
6735 "}\n"
6736 "}\n"
6737 "proc tkTextClosestGap {w x y} {\n"
6738 "set pos [$w index @$x,$y]\n"
6739 "set bbox [$w bbox $pos]\n"
6740 "if {[string equal $bbox \"\"]} {\n"
6741 "return $pos\n"
6742 "}\n"
6743 "if {($x - [lindex $bbox 0]) < ([lindex $bbox 2]/2)} {\n"
6744 "return $pos\n"
6745 "}\n"
6746 "$w index \"$pos + 1 char\"\n"
6747 "}\n"
6748 "proc tkTextButton1 {w x y} {\n"
6749 "global tkPriv\n"
6750 "set tkPriv(selectMode) char\n"
6751 "set tkPriv(mouseMoved) 0\n"
6752 "set tkPriv(pressX) $x\n"
6753 "$w mark set insert [tkTextClosestGap $w $x $y]\n"
6754 "$w mark set anchor insert\n"
6755 "if {[string equal [$w cget -state] \"normal\"]} {focus $w}\n"
6756 "}\n"
6757 "proc tkTextSelectTo {w x y {extend 0}} {\n"
6758 "global tkPriv tcl_platform\n"
6759 "set cur [tkTextClosestGap $w $x $y]\n"
6760 "if {[catch {$w index anchor}]} {\n"
6761 "$w mark set anchor $cur\n"
6762 "}\n"
6763 "set anchor [$w index anchor]\n"
6764 "if {[$w compare $cur != $anchor] || (abs($tkPriv(pressX) - $x) >= 3)} {\n"
6765 "set tkPriv(mouseMoved) 1\n"
6766 "}\n"
6767 "switch $tkPriv(selectMode) {\n"
6768 "char {\n"
6769 "if {[$w compare $cur < anchor]} {\n"
6770 "set first $cur\n"
6771 "set last anchor\n"
6772 "} else {\n"
6773 "set first anchor\n"
6774 "set last $cur\n"
6775 "}\n"
6776 "}\n"
6777 "word {\n"
6778 "if {[$w compare $cur < anchor]} {\n"
6779 "set first [tkTextPrevPos $w \"$cur + 1c\" tcl_wordBreakBefore]\n"
6780 "if { !$extend } {\n"
6781 "set last [tkTextNextPos $w \"anchor\" tcl_wordBreakAfter]\n"
6782 "} else {\n"
6783 "set last anchor\n"
6784 "}\n"
6785 "} else {\n"
6786 "set last [tkTextNextPos $w \"$cur - 1c\" tcl_wordBreakAfter]\n"
6787 "if { !$extend } {\n"
6788 "set first [tkTextPrevPos $w anchor tcl_wordBreakBefore]\n"
6789 "} else {\n"
6790 "set first anchor\n"
6791 "}\n"
6792 "}\n"
6793 "}\n"
6794 "line {\n"
6795 "if {[$w compare $cur < anchor]} {\n"
6796 "set first [$w index \"$cur linestart\"]\n"
6797 "set last [$w index \"anchor - 1c lineend + 1c\"]\n"
6798 "} else {\n"
6799 "set first [$w index \"anchor linestart\"]\n"
6800 "set last [$w index \"$cur lineend + 1c\"]\n"
6801 "}\n"
6802 "}\n"
6803 "}\n"
6804 "if {$tkPriv(mouseMoved) || [string compare $tkPriv(selectMode) \"char\"]} {\n"
6805 "if {[string compare $tcl_platform(platform) \"unix\"] \\\n"
6806 "\011\011&& [$w compare $cur < anchor]} {\n"
6807 "$w mark set insert $first\n"
6808 "} else {\n"
6809 "$w mark set insert $last\n"
6810 "}\n"
6811 "$w tag remove sel 0.0 $first\n"
6812 "$w tag add sel $first $last\n"
6813 "$w tag remove sel $last end\n"
6814 "update idletasks\n"
6815 "}\n"
6816 "}\n"
6817 "proc tkTextKeyExtend {w index} {\n"
6818 "global tkPriv\n"
6819 "set cur [$w index $index]\n"
6820 "if {[catch {$w index anchor}]} {\n"
6821 "$w mark set anchor $cur\n"
6822 "}\n"
6823 "set anchor [$w index anchor]\n"
6824 "if {[$w compare $cur < anchor]} {\n"
6825 "set first $cur\n"
6826 "set last anchor\n"
6827 "} else {\n"
6828 "set first anchor\n"
6829 "set last $cur\n"
6830 "}\n"
6831 "$w tag remove sel 0.0 $first\n"
6832 "$w tag add sel $first $last\n"
6833 "$w tag remove sel $last end\n"
6834 "}\n"
6835 "proc tkTextPaste {w x y} {\n"
6836 "$w mark set insert [tkTextClosestGap $w $x $y]\n"
6837 "catch {$w insert insert [selection get -displayof $w]}\n"
6838 "if {[string equal [$w cget -state] \"normal\"]} {focus $w}\n"
6839 "}\n"
6840 "proc tkTextAutoScan {w} {\n"
6841 "global tkPriv\n"
6842 "if {![winfo exists $w]} return\n"
6843 "if {$tkPriv(y) >= [winfo height $w]} {\n"
6844 "$w yview scroll 2 units\n"
6845 "} elseif {$tkPriv(y) < 0} {\n"
6846 "$w yview scroll -2 units\n"
6847 "} elseif {$tkPriv(x) >= [winfo width $w]} {\n"
6848 "$w xview scroll 2 units\n"
6849 "} elseif {$tkPriv(x) < 0} {\n"
6850 "$w xview scroll -2 units\n"
6851 "} else {\n"
6852 "return\n"
6853 "}\n"
6854 "tkTextSelectTo $w $tkPriv(x) $tkPriv(y)\n"
6855 "set tkPriv(afterId) [after 50 [list tkTextAutoScan $w]]\n"
6856 "}\n"
6857 "proc tkTextSetCursor {w pos} {\n"
6858 "global tkPriv\n"
6859 "if {[$w compare $pos == end]} {\n"
6860 "set pos {end - 1 chars}\n"
6861 "}\n"
6862 "$w mark set insert $pos\n"
6863 "$w tag remove sel 1.0 end\n"
6864 "$w see insert\n"
6865 "}\n"
6866 "proc tkTextKeySelect {w new} {\n"
6867 "global tkPriv\n"
6868 "if {[string equal [$w tag nextrange sel 1.0 end] \"\"]} {\n"
6869 "if {[$w compare $new < insert]} {\n"
6870 "$w tag add sel $new insert\n"
6871 "} else {\n"
6872 "$w tag add sel insert $new\n"
6873 "}\n"
6874 "$w mark set anchor insert\n"
6875 "} else {\n"
6876 "if {[$w compare $new < anchor]} {\n"
6877 "set first $new\n"
6878 "set last anchor\n"
6879 "} else {\n"
6880 "set first anchor\n"
6881 "set last $new\n"
6882 "}\n"
6883 "$w tag remove sel 1.0 $first\n"
6884 "$w tag add sel $first $last\n"
6885 "$w tag remove sel $last end\n"
6886 "}\n"
6887 "$w mark set insert $new\n"
6888 "$w see insert\n"
6889 "update idletasks\n"
6890 "}\n"
6891 "proc tkTextResetAnchor {w index} {\n"
6892 "global tkPriv\n"
6893 "if {[string equal [$w tag ranges sel] \"\"]} {\n"
6894 "$w mark set anchor $index\n"
6895 "return\n"
6896 "}\n"
6897 "set a [$w index $index]\n"
6898 "set b [$w index sel.first]\n"
6899 "set c [$w index sel.last]\n"
6900 "if {[$w compare $a < $b]} {\n"
6901 "$w mark set anchor sel.last\n"
6902 "return\n"
6903 "}\n"
6904 "if {[$w compare $a > $c]} {\n"
6905 "$w mark set anchor sel.first\n"
6906 "return\n"
6907 "}\n"
6908 "scan $a \"%d.%d\" lineA chA\n"
6909 "scan $b \"%d.%d\" lineB chB\n"
6910 "scan $c \"%d.%d\" lineC chC\n"
6911 "if {$lineB < $lineC+2} {\n"
6912 "set total [string length [$w get $b $c]]\n"
6913 "if {$total <= 2} {\n"
6914 "return\n"
6915 "}\n"
6916 "if {[string length [$w get $b $a]] < ($total/2)} {\n"
6917 "$w mark set anchor sel.last\n"
6918 "} else {\n"
6919 "$w mark set anchor sel.first\n"
6920 "}\n"
6921 "return\n"
6922 "}\n"
6923 "if {($lineA-$lineB) < ($lineC-$lineA)} {\n"
6924 "$w mark set anchor sel.last\n"
6925 "} else {\n"
6926 "$w mark set anchor sel.first\n"
6927 "}\n"
6928 "}\n"
6929 "proc tkTextInsert {w s} {\n"
6930 "if {[string equal $s \"\"] || [string equal [$w cget -state] \"disabled\"]} {\n"
6931 "return\n"
6932 "}\n"
6933 "catch {\n"
6934 "if {[$w compare sel.first <= insert] \\\n"
6935 "\011\011&& [$w compare sel.last >= insert]} {\n"
6936 "$w delete sel.first sel.last\n"
6937 "}\n"
6938 "}\n"
6939 "$w insert insert $s\n"
6940 "$w see insert\n"
6941 "}\n"
6942 "proc tkTextUpDownLine {w n} {\n"
6943 "global tkPriv\n"
6944 "set i [$w index insert]\n"
6945 "scan $i \"%d.%d\" line char\n"
6946 "if {[string compare $tkPriv(prevPos) $i]} {\n"
6947 "set tkPriv(char) $char\n"
6948 "}\n"
6949 "set new [$w index [expr {$line + $n}].$tkPriv(char)]\n"
6950 "if {[$w compare $new == end] || [$w compare $new == \"insert linestart\"]} {\n"
6951 "set new $i\n"
6952 "}\n"
6953 "set tkPriv(prevPos) $new\n"
6954 "return $new\n"
6955 "}\n"
6956 "proc tkTextPrevPara {w pos} {\n"
6957 "set pos [$w index \"$pos linestart\"]\n"
6958 "while {1} {\n"
6959 "if {([string equal [$w get \"$pos - 1 line\"] \"\\n\"] \\\n"
6960 "\011\011&& [string compare [$w get $pos] \"\\n\"]) \\\n"
6961 "\011\011|| [string equal $pos \"1.0\"]} {\n"
6962 "if {[regexp -indices {^[ \011]+(.)} [$w get $pos \"$pos lineend\"] \\\n"
6963 "\011\011 dummy index]} {\n"
6964 "set pos [$w index \"$pos + [lindex $index 0] chars\"]\n"
6965 "}\n"
6966 "if {[$w compare $pos != insert] || [string equal $pos 1.0]} {\n"
6967 "return $pos\n"
6968 "}\n"
6969 "}\n"
6970 "set pos [$w index \"$pos - 1 line\"]\n"
6971 "}\n"
6972 "}\n"
6973 "proc tkTextNextPara {w start} {\n"
6974 "set pos [$w index \"$start linestart + 1 line\"]\n"
6975 "while {[string compare [$w get $pos] \"\\n\"]} {\n"
6976 "if {[$w compare $pos == end]} {\n"
6977 "return [$w index \"end - 1c\"]\n"
6978 "}\n"
6979 "set pos [$w index \"$pos + 1 line\"]\n"
6980 "}\n"
6981 "while {[string equal [$w get $pos] \"\\n\"]} {\n"
6982 "set pos [$w index \"$pos + 1 line\"]\n"
6983 "if {[$w compare $pos == end]} {\n"
6984 "return [$w index \"end - 1c\"]\n"
6985 "}\n"
6986 "}\n"
6987 "if {[regexp -indices {^[ \011]+(.)} [$w get $pos \"$pos lineend\"] \\\n"
6988 "\011 dummy index]} {\n"
6989 "return [$w index \"$pos + [lindex $index 0] chars\"]\n"
6990 "}\n"
6991 "return $pos\n"
6992 "}\n"
6993 "proc tkTextScrollPages {w count} {\n"
6994 "set bbox [$w bbox insert]\n"
6995 "$w yview scroll $count pages\n"
6996 "if {[string equal $bbox \"\"]} {\n"
6997 "return [$w index @[expr {[winfo height $w]/2}],0]\n"
6998 "}\n"
6999 "return [$w index @[lindex $bbox 0],[lindex $bbox 1]]\n"
7000 "}\n"
7001 "proc tkTextTranspose w {\n"
7002 "set pos insert\n"
7003 "if {[$w compare $pos != \"$pos lineend\"]} {\n"
7004 "set pos [$w index \"$pos + 1 char\"]\n"
7005 "}\n"
7006 "set new [$w get \"$pos - 1 char\"][$w get \"$pos - 2 char\"]\n"
7007 "if {[$w compare \"$pos - 1 char\" == 1.0]} {\n"
7008 "return\n"
7009 "}\n"
7010 "$w delete \"$pos - 2 char\" $pos\n"
7011 "$w insert insert $new\n"
7012 "$w see insert\n"
7013 "}\n"
7014 "proc tk_textCopy w {\n"
7015 "if {![catch {set data [$w get sel.first sel.last]}]} {\n"
7016 "clipboard clear -displayof $w\n"
7017 "clipboard append -displayof $w $data\n"
7018 "}\n"
7019 "}\n"
7020 "proc tk_textCut w {\n"
7021 "if {![catch {set data [$w get sel.first sel.last]}]} {\n"
7022 "clipboard clear -displayof $w\n"
7023 "clipboard append -displayof $w $data\n"
7024 "$w delete sel.first sel.last\n"
7025 "}\n"
7026 "}\n"
7027 "proc tk_textPaste w {\n"
7028 "global tcl_platform\n"
7029 "catch {\n"
7030 "if {[string compare $tcl_platform(platform) \"unix\"]} {\n"
7031 "catch {\n"
7032 "$w delete sel.first sel.last\n"
7033 "}\n"
7034 "}\n"
7035 "$w insert insert [selection get -displayof $w -selection CLIPBOARD]\n"
7036 "}\n"
7037 "}\n"
7038 "if {[string equal $tcl_platform(platform) \"windows\"]} {\n"
7039 "proc tkTextNextWord {w start} {\n"
7040 "tkTextNextPos $w [tkTextNextPos $w $start tcl_endOfWord] \\\n"
7041 "\011 tcl_startOfNextWord\n"
7042 "}\n"
7043 "} else {\n"
7044 "proc tkTextNextWord {w start} {\n"
7045 "tkTextNextPos $w $start tcl_endOfWord\n"
7046 "}\n"
7047 "}\n"
7048 "proc tkTextNextPos {w start op} {\n"
7049 "set text \"\"\n"
7050 "set cur $start\n"
7051 "while {[$w compare $cur < end]} {\n"
7052 "set text $text[$w get $cur \"$cur lineend + 1c\"]\n"
7053 "set pos [$op $text 0]\n"
7054 "if {$pos >= 0} {\n"
7055 "set dump [$w dump -image -window $start \"$start + $pos c\"]\n"
7056 "if {[llength $dump]} {\n"
7057 "set pos [expr {$pos + ([llength $dump]/3)}]\n"
7058 "}\n"
7059 "return [$w index \"$start + $pos c\"]\n"
7060 "}\n"
7061 "set cur [$w index \"$cur lineend +1c\"]\n"
7062 "}\n"
7063 "return end\n"
7064 "}\n"
7065 "proc tkTextPrevPos {w start op} {\n"
7066 "set text \"\"\n"
7067 "set cur $start\n"
7068 "while {[$w compare $cur > 0.0]} {\n"
7069 "set text [$w get \"$cur linestart - 1c\" $cur]$text\n"
7070 "set pos [$op $text end]\n"
7071 "if {$pos >= 0} {\n"
7072 "set dump [$w dump -image -window \"$cur linestart\" \"$start - 1c\"]\n"
7073 "if {[llength $dump]} {\n"
7074 "if {[$w compare [lindex $dump 2] > \\\n"
7075 "\011\011\011\"$cur linestart - 1c + $pos c\"]} {\n"
7076 "incr pos -1\n"
7077 "}\n"
7078 "set pos [expr {$pos + ([llength $dump]/3)}]\n"
7079 "}\n"
7080 "return [$w index \"$cur linestart - 1c + $pos c\"]\n"
7081 "}\n"
7082 "set cur [$w index \"$cur linestart - 1c\"]\n"
7083 "}\n"
7084 "return 0.0\n"
7085 "}\n"
7086 ;
7087 static char Et_zFile28[] =
7088 "package require -exact Tk 8.3\n"
7089 "package require -exact Tcl 8.3\n"
7090 "if {[info exists auto_path] && [string compare {} $tk_library] && \\\n"
7091 "\011[lsearch -exact $auto_path $tk_library] < 0} {\n"
7092 "lappend auto_path $tk_library\n"
7093 "}\n"
7094 "set tk_strictMotif 0\n"
7095 "namespace eval ::tk {\n"
7096 "}\n"
7097 "proc ::tk::PlaceWindow {w {place \"\"} {anchor \"\"}} {\n"
7098 "wm withdraw $w\n"
7099 "update idletasks\n"
7100 "set checkBounds 1\n"
7101 "if {[string equal -len [string length $place] $place \"pointer\"]} {\n"
7102 "if {[string equal -len [string length $anchor] $anchor \"center\"]} {\n"
7103 "set x [expr {[winfo pointerx $w]-[winfo reqwidth $w]/2}]\n"
7104 "set y [expr {[winfo pointery $w]-[winfo reqheight $w]/2}]\n"
7105 "} else {\n"
7106 "set x [winfo pointerx $w]\n"
7107 "set y [winfo pointery $w]\n"
7108 "}\n"
7109 "} elseif {[string equal -len [string length $place] $place \"widget\"] && \\\n"
7110 "\011 [winfo exists $anchor] && [winfo ismapped $anchor]} {\n"
7111 "set x [expr {[winfo rootx $anchor] + \\\n"
7112 "\011\011([winfo width $anchor]-[winfo reqwidth $w])/2}]\n"
7113 "set y [expr {[winfo rooty $anchor] + \\\n"
7114 "\011\011([winfo height $anchor]-[winfo reqheight $w])/2}]\n"
7115 "} else {\n"
7116 "set x [expr {([winfo screenwidth $w]-[winfo reqwidth $w])/2}]\n"
7117 "set y [expr {([winfo screenheight $w]-[winfo reqheight $w])/2}]\n"
7118 "set checkBounds 0\n"
7119 "}\n"
7120 "if {$checkBounds} {\n"
7121 "if {$x < 0} {\n"
7122 "set x 0\n"
7123 "} elseif {$x > ([winfo screenwidth $w]-[winfo reqwidth $w])} {\n"
7124 "set x [expr {[winfo screenwidth $w]-[winfo reqwidth $w]}]\n"
7125 "}\n"
7126 "if {$y < 0} {\n"
7127 "set y 0\n"
7128 "} elseif {$y > ([winfo screenheight $w]-[winfo reqheight $w])} {\n"
7129 "set y [expr {[winfo screenheight $w]-[winfo reqheight $w]}]\n"
7130 "}\n"
7131 "}\n"
7132 "wm geometry $w +$x+$y\n"
7133 "wm deiconify $w\n"
7134 "}\n"
7135 "proc ::tk::SetFocusGrab {grab {focus {}}} {\n"
7136 "set index \"$grab,$focus\"\n"
7137 "upvar ::tk::FocusGrab($index) data\n"
7138 "lappend data [focus]\n"
7139 "set oldGrab [grab current $grab]\n"
7140 "lappend data $oldGrab\n"
7141 "if {[winfo exists $oldGrab]} {\n"
7142 "lappend data [grab status $oldGrab]\n"
7143 "}\n"
7144 "grab $grab\n"
7145 "if {[winfo exists $focus]} {\n"
7146 "focus $focus\n"
7147 "}\n"
7148 "}\n"
7149 "proc ::tk::RestoreFocusGrab {grab focus {destroy destroy}} {\n"
7150 "set index \"$grab,$focus\"\n"
7151 "foreach {oldFocus oldGrab oldStatus} $::tk::FocusGrab($index) { break }\n"
7152 "unset ::tk::FocusGrab($index)\n"
7153 "catch {focus $oldFocus}\n"
7154 "grab release $grab\n"
7155 "if {[string equal $destroy \"withdraw\"]} {\n"
7156 "wm withdraw $grab\n"
7157 "} else {\n"
7158 "destroy $grab\n"
7159 "}\n"
7160 "if {[winfo exists $oldGrab] && [winfo ismapped $oldGrab]} {\n"
7161 "if {[string equal $oldStatus \"global\"]} {\n"
7162 "grab -global $oldGrab\n"
7163 "} else {\n"
7164 "grab $oldGrab\n"
7165 "}\n"
7166 "}\n"
7167 "}\n"
7168 "proc tkScreenChanged screen {\n"
7169 "set x [string last . $screen]\n"
7170 "if {$x > 0} {\n"
7171 "set disp [string range $screen 0 [expr {$x - 1}]]\n"
7172 "} else {\n"
7173 "set disp $screen\n"
7174 "}\n"
7175 "uplevel #0 upvar #0 tkPriv.$disp tkPriv\n"
7176 "global tkPriv\n"
7177 "global tcl_platform\n"
7178 "if {[info exists tkPriv]} {\n"
7179 "set tkPriv(screen) $screen\n"
7180 "return\n"
7181 "}\n"
7182 "array set tkPriv {\n"
7183 "activeMenu\011{}\n"
7184 "activeItem\011{}\n"
7185 "afterId\011\011{}\n"
7186 "buttons\011\0110\n"
7187 "buttonWindow\011{}\n"
7188 "dragging\0110\n"
7189 "focus\011\011{}\n"
7190 "grab\011\011{}\n"
7191 "initPos\011\011{}\n"
7192 "inMenubutton\011{}\n"
7193 "listboxPrev\011{}\n"
7194 "menuBar\011\011{}\n"
7195 "mouseMoved\0110\n"
7196 "oldGrab\011\011{}\n"
7197 "popup\011\011{}\n"
7198 "postedMb\011{}\n"
7199 "pressX\011\0110\n"
7200 "pressY\011\0110\n"
7201 "prevPos\011\0110\n"
7202 "selectMode\011char\n"
7203 "}\n"
7204 "set tkPriv(screen) $screen\n"
7205 "set tkPriv(tearoff) [string equal $tcl_platform(platform) \"unix\"]\n"
7206 "set tkPriv(window) {}\n"
7207 "}\n"
7208 "tkScreenChanged [winfo screen .]\n"
7209 "proc tkEventMotifBindings {n1 dummy dummy} {\n"
7210 "upvar $n1 name\n"
7211 "if {$name} {\n"
7212 "set op delete\n"
7213 "} else {\n"
7214 "set op add\n"
7215 "}\n"
7216 "event $op <<Cut>> <Control-Key-w>\n"
7217 "event $op <<Copy>> <Meta-Key-w> \n"
7218 "event $op <<Paste>> <Control-Key-y>\n"
7219 "}\n"
7220 "if {[string equal [info commands tk_chooseColor] \"\"]} {\n"
7221 "proc tk_chooseColor {args} {\n"
7222 "return [eval tkColorDialog $args]\n"
7223 "}\n"
7224 "}\n"
7225 "if {[string equal [info commands tk_getOpenFile] \"\"]} {\n"
7226 "proc tk_getOpenFile {args} {\n"
7227 "if {$::tk_strictMotif} {\n"
7228 "return [eval tkMotifFDialog open $args]\n"
7229 "} else {\n"
7230 "return [eval ::tk::dialog::file::tkFDialog open $args]\n"
7231 "}\n"
7232 "}\n"
7233 "}\n"
7234 "if {[string equal [info commands tk_getSaveFile] \"\"]} {\n"
7235 "proc tk_getSaveFile {args} {\n"
7236 "if {$::tk_strictMotif} {\n"
7237 "return [eval tkMotifFDialog save $args]\n"
7238 "} else {\n"
7239 "return [eval ::tk::dialog::file::tkFDialog save $args]\n"
7240 "}\n"
7241 "}\n"
7242 "}\n"
7243 "if {[string equal [info commands tk_messageBox] \"\"]} {\n"
7244 "proc tk_messageBox {args} {\n"
7245 "return [eval tkMessageBox $args]\n"
7246 "}\n"
7247 "}\n"
7248 "if {[string equal [info command tk_chooseDirectory] \"\"]} {\n"
7249 "proc tk_chooseDirectory {args} {\n"
7250 "return [eval ::tk::dialog::file::chooseDir::tkChooseDirectory $args]\n"
7251 "}\n"
7252 "}\n"
7253 "switch $tcl_platform(platform) {\n"
7254 "\"unix\" {\n"
7255 "event add <<Cut>> <Control-Key-x> <Key-F20> \n"
7256 "event add <<Copy>> <Control-Key-c> <Key-F16>\n"
7257 "event add <<Paste>> <Control-Key-v> <Key-F18>\n"
7258 "event add <<PasteSelection>> <ButtonRelease-2>\n"
7259 "if {[info exists tcl_platform(os)]} {\n"
7260 "switch $tcl_platform(os) {\n"
7261 "\"IRIX\" -\n"
7262 "\"Linux\" { event add <<PrevWindow>> <ISO_Left_Tab> }\n"
7263 "\"HP-UX\" { event add <<PrevWindow>> <hpBackTab> }\n"
7264 "}\n"
7265 "}\n"
7266 "trace variable tk_strictMotif w tkEventMotifBindings\n"
7267 "set tk_strictMotif $tk_strictMotif\n"
7268 "}\n"
7269 "\"windows\" {\n"
7270 "event add <<Cut>> <Control-Key-x> <Shift-Key-Delete>\n"
7271 "event add <<Copy>> <Control-Key-c> <Control-Key-Insert>\n"
7272 "event add <<Paste>> <Control-Key-v> <Shift-Key-Insert>\n"
7273 "event add <<PasteSelection>> <ButtonRelease-2>\n"
7274 "}\n"
7275 "\"macintosh\" {\n"
7276 "event add <<Cut>> <Control-Key-x> <Key-F2> \n"
7277 "event add <<Copy>> <Control-Key-c> <Key-F3>\n"
7278 "event add <<Paste>> <Control-Key-v> <Key-F4>\n"
7279 "event add <<PasteSelection>> <ButtonRelease-2>\n"
7280 "event add <<Clear>> <Clear>\n"
7281 "}\n"
7282 "}\n"
7283 "if {[string compare $tcl_platform(platform) \"macintosh\"] && \\\n"
7284 "\011[string compare {} $tk_library]} {\n"
7285 "source [file join $tk_library button.tcl]\n"
7286 "source [file join $tk_library entry.tcl]\n"
7287 "source [file join $tk_library listbox.tcl]\n"
7288 "source [file join $tk_library menu.tcl]\n"
7289 "source [file join $tk_library scale.tcl]\n"
7290 "source [file join $tk_library scrlbar.tcl]\n"
7291 "source [file join $tk_library text.tcl]\n"
7292 "}\n"
7293 "event add <<PrevWindow>> <Shift-Tab>\n"
7294 "bind all <Tab> {tkTabToWindow [tk_focusNext %W]}\n"
7295 "bind all <<PrevWindow>> {tkTabToWindow [tk_focusPrev %W]}\n"
7296 "proc tkCancelRepeat {} {\n"
7297 "global tkPriv\n"
7298 "after cancel $tkPriv(afterId)\n"
7299 "set tkPriv(afterId) {}\n"
7300 "}\n"
7301 "proc tkTabToWindow {w} {\n"
7302 "if {[string equal [winfo class $w] Entry]} {\n"
7303 "$w selection range 0 end\n"
7304 "$w icursor end\n"
7305 "}\n"
7306 "focus $w\n"
7307 "}\n"
7308 ;
7309 static char Et_zFile29[] =
7310 "proc tkIconList {w args} {\n"
7311 "upvar #0 $w data\n"
7312 "tkIconList_Config $w $args\n"
7313 "tkIconList_Create $w\n"
7314 "}\n"
7315 "proc tkIconList_Config {w argList} {\n"
7316 "upvar #0 $w data\n"
7317 "set specs {\n"
7318 "{-browsecmd \"\" \"\" \"\"}\n"
7319 "{-command \"\" \"\" \"\"}\n"
7320 "}\n"
7321 "tclParseConfigSpec $w $specs \"\" $argList\n"
7322 "}\n"
7323 "proc tkIconList_Create {w} {\n"
7324 "upvar #0 $w data\n"
7325 "frame $w\n"
7326 "set data(sbar) [scrollbar $w.sbar -orient horizontal \\\n"
7327 "\011-highlightthickness 0 -takefocus 0]\n"
7328 "set data(canvas) [canvas $w.canvas -bd 2 -relief sunken \\\n"
7329 "\011-width 400 -height 120 -takefocus 1]\n"
7330 "pack $data(sbar) -side bottom -fill x -padx 2\n"
7331 "pack $data(canvas) -expand yes -fill both\n"
7332 "$data(sbar) config -command [list $data(canvas) xview]\n"
7333 "$data(canvas) config -xscrollcommand [list $data(sbar) set]\n"
7334 "set data(maxIW) 1\n"
7335 "set data(maxIH) 1\n"
7336 "set data(maxTW) 1\n"
7337 "set data(maxTH) 1\n"
7338 "set data(numItems) 0\n"
7339 "set data(curItem) {}\n"
7340 "set data(noScroll) 1\n"
7341 "bind $data(canvas) <Configure>\011[list tkIconList_Arrange $w]\n"
7342 "bind $data(canvas) <1>\011\011[list tkIconList_Btn1 $w %x %y]\n"
7343 "bind $data(canvas) <B1-Motion>\011[list tkIconList_Motion1 $w %x %y]\n"
7344 "bind $data(canvas) <B1-Leave>\011[list tkIconList_Leave1 $w %x %y]\n"
7345 "bind $data(canvas) <B1-Enter>\011[list tkCancelRepeat]\n"
7346 "bind $data(canvas) <ButtonRelease-1> [list tkCancelRepeat]\n"
7347 "bind $data(canvas) <Double-ButtonRelease-1> \\\n"
7348 "\011 [list tkIconList_Double1 $w %x %y]\n"
7349 "bind $data(canvas) <Up>\011\011[list tkIconList_UpDown $w -1]\n"
7350 "bind $data(canvas) <Down>\011\011[list tkIconList_UpDown $w 1]\n"
7351 "bind $data(canvas) <Left>\011\011[list tkIconList_LeftRight $w -1]\n"
7352 "bind $data(canvas) <Right>\011\011[list tkIconList_LeftRight $w 1]\n"
7353 "bind $data(canvas) <Return>\011\011[list tkIconList_ReturnKey $w]\n"
7354 "bind $data(canvas) <KeyPress>\011[list tkIconList_KeyPress $w %A]\n"
7355 "bind $data(canvas) <Control-KeyPress> \";\"\n"
7356 "bind $data(canvas) <Alt-KeyPress>\011\";\"\n"
7357 "bind $data(canvas) <FocusIn>\011[list tkIconList_FocusIn $w]\n"
7358 "return $w\n"
7359 "}\n"
7360 "proc tkIconList_AutoScan {w} {\n"
7361 "upvar #0 $w data\n"
7362 "global tkPriv\n"
7363 "if {![winfo exists $w]} return\n"
7364 "set x $tkPriv(x)\n"
7365 "set y $tkPriv(y)\n"
7366 "if {$data(noScroll)} {\n"
7367 "return\n"
7368 "}\n"
7369 "if {$x >= [winfo width $data(canvas)]} {\n"
7370 "$data(canvas) xview scroll 1 units\n"
7371 "} elseif {$x < 0} {\n"
7372 "$data(canvas) xview scroll -1 units\n"
7373 "} elseif {$y >= [winfo height $data(canvas)]} {\n"
7374 "} elseif {$y < 0} {\n"
7375 "} else {\n"
7376 "return\n"
7377 "}\n"
7378 "tkIconList_Motion1 $w $x $y\n"
7379 "set tkPriv(afterId) [after 50 [list tkIconList_AutoScan $w]]\n"
7380 "}\n"
7381 "proc tkIconList_DeleteAll {w} {\n"
7382 "upvar #0 $w data\n"
7383 "upvar #0 $w:itemList itemList\n"
7384 "$data(canvas) delete all\n"
7385 "catch {unset data(selected)}\n"
7386 "catch {unset data(rect)}\n"
7387 "catch {unset data(list)}\n"
7388 "catch {unset itemList}\n"
7389 "set data(maxIW) 1\n"
7390 "set data(maxIH) 1\n"
7391 "set data(maxTW) 1\n"
7392 "set data(maxTH) 1\n"
7393 "set data(numItems) 0\n"
7394 "set data(curItem) {}\n"
7395 "set data(noScroll) 1\n"
7396 "$data(sbar) set 0.0 1.0\n"
7397 "$data(canvas) xview moveto 0\n"
7398 "}\n"
7399 "proc tkIconList_Add {w image text} {\n"
7400 "upvar #0 $w data\n"
7401 "upvar #0 $w:itemList itemList\n"
7402 "upvar #0 $w:textList textList\n"
7403 "set iTag [$data(canvas) create image 0 0 -image $image -anchor nw]\n"
7404 "set tTag [$data(canvas) create text 0 0 -text $text -anchor nw \\\n"
7405 "\011-font $data(font)]\n"
7406 "set rTag [$data(canvas) create rect 0 0 0 0 -fill \"\" -outline \"\"]\n"
7407 "set b [$data(canvas) bbox $iTag]\n"
7408 "set iW [expr {[lindex $b 2]-[lindex $b 0]}]\n"
7409 "set iH [expr {[lindex $b 3]-[lindex $b 1]}]\n"
7410 "if {$data(maxIW) < $iW} {\n"
7411 "set data(maxIW) $iW\n"
7412 "}\n"
7413 "if {$data(maxIH) < $iH} {\n"
7414 "set data(maxIH) $iH\n"
7415 "}\n"
7416 "set b [$data(canvas) bbox $tTag]\n"
7417 "set tW [expr {[lindex $b 2]-[lindex $b 0]}]\n"
7418 "set tH [expr {[lindex $b 3]-[lindex $b 1]}]\n"
7419 "if {$data(maxTW) < $tW} {\n"
7420 "set data(maxTW) $tW\n"
7421 "}\n"
7422 "if {$data(maxTH) < $tH} {\n"
7423 "set data(maxTH) $tH\n"
7424 "}\n"
7425 "lappend data(list) [list $iTag $tTag $rTag $iW $iH $tW $tH $data(numItems)]\n"
7426 "set itemList($rTag) [list $iTag $tTag $text $data(numItems)]\n"
7427 "set textList($data(numItems)) [string tolower $text]\n"
7428 "incr data(numItems)\n"
7429 "}\n"
7430 "proc tkIconList_Arrange {w} {\n"
7431 "upvar #0 $w data\n"
7432 "if {![info exists data(list)]} {\n"
7433 "if {[info exists data(canvas)] && [winfo exists $data(canvas)]} {\n"
7434 "set data(noScroll) 1\n"
7435 "$data(sbar) config -command \"\"\n"
7436 "}\n"
7437 "return\n"
7438 "}\n"
7439 "set W [winfo width $data(canvas)]\n"
7440 "set H [winfo height $data(canvas)]\n"
7441 "set pad [expr {[$data(canvas) cget -highlightthickness] + \\\n"
7442 "\011 [$data(canvas) cget -bd]}]\n"
7443 "if {$pad < 2} {\n"
7444 "set pad 2\n"
7445 "}\n"
7446 "incr W -[expr {$pad*2}]\n"
7447 "incr H -[expr {$pad*2}]\n"
7448 "set dx [expr {$data(maxIW) + $data(maxTW) + 8}]\n"
7449 "if {$data(maxTH) > $data(maxIH)} {\n"
7450 "set dy $data(maxTH)\n"
7451 "} else {\n"
7452 "set dy $data(maxIH)\n"
7453 "}\n"
7454 "incr dy 2\n"
7455 "set shift [expr {$data(maxIW) + 4}]\n"
7456 "set x [expr {$pad * 2}]\n"
7457 "set y [expr {$pad * 1}] ; # Why * 1 ?\n"
7458 "set usedColumn 0\n"
7459 "foreach sublist $data(list) {\n"
7460 "set usedColumn 1\n"
7461 "set iTag [lindex $sublist 0]\n"
7462 "set tTag [lindex $sublist 1]\n"
7463 "set rTag [lindex $sublist 2]\n"
7464 "set iW [lindex $sublist 3]\n"
7465 "set iH [lindex $sublist 4]\n"
7466 "set tW [lindex $sublist 5]\n"
7467 "set tH [lindex $sublist 6]\n"
7468 "set i_dy [expr {($dy - $iH)/2}]\n"
7469 "set t_dy [expr {($dy - $tH)/2}]\n"
7470 "$data(canvas) coords $iTag $x [expr {$y + $i_dy}]\n"
7471 "$data(canvas) coords $tTag [expr {$x + $shift}] [expr {$y + $t_dy}]\n"
7472 "$data(canvas) coords $tTag [expr {$x + $shift}] [expr {$y + $t_dy}]\n"
7473 "$data(canvas) coords $rTag $x $y [expr {$x+$dx}] [expr {$y+$dy}]\n"
7474 "incr y $dy\n"
7475 "if {($y + $dy) > $H} {\n"
7476 "set y [expr {$pad * 1}] ; # *1 ?\n"
7477 "incr x $dx\n"
7478 "set usedColumn 0\n"
7479 "}\n"
7480 "}\n"
7481 "if {$usedColumn} {\n"
7482 "set sW [expr {$x + $dx}]\n"
7483 "} else {\n"
7484 "set sW $x\n"
7485 "}\n"
7486 "if {$sW < $W} {\n"
7487 "$data(canvas) config -scrollregion [list $pad $pad $sW $H]\n"
7488 "$data(sbar) config -command \"\"\n"
7489 "$data(canvas) xview moveto 0\n"
7490 "set data(noScroll) 1\n"
7491 "} else {\n"
7492 "$data(canvas) config -scrollregion [list $pad $pad $sW $H]\n"
7493 "$data(sbar) config -command [list $data(canvas) xview]\n"
7494 "set data(noScroll) 0\n"
7495 "}\n"
7496 "set data(itemsPerColumn) [expr {($H-$pad)/$dy}]\n"
7497 "if {$data(itemsPerColumn) < 1} {\n"
7498 "set data(itemsPerColumn) 1\n"
7499 "}\n"
7500 "if {$data(curItem) != \"\"} {\n"
7501 "tkIconList_Select $w [lindex [lindex $data(list) $data(curItem)] 2] 0\n"
7502 "}\n"
7503 "}\n"
7504 "proc tkIconList_Invoke {w} {\n"
7505 "upvar #0 $w data\n"
7506 "if {$data(-command) != \"\" && [info exists data(selected)]} {\n"
7507 "uplevel #0 $data(-command)\n"
7508 "}\n"
7509 "}\n"
7510 "proc tkIconList_See {w rTag} {\n"
7511 "upvar #0 $w data\n"
7512 "upvar #0 $w:itemList itemList\n"
7513 "if {$data(noScroll)} {\n"
7514 "return\n"
7515 "}\n"
7516 "set sRegion [$data(canvas) cget -scrollregion]\n"
7517 "if {[string equal $sRegion {}]} {\n"
7518 "return\n"
7519 "}\n"
7520 "if {![info exists itemList($rTag)]} {\n"
7521 "return\n"
7522 "}\n"
7523 "set bbox [$data(canvas) bbox $rTag]\n"
7524 "set pad [expr {[$data(canvas) cget -highlightthickness] + \\\n"
7525 "\011 [$data(canvas) cget -bd]}]\n"
7526 "set x1 [lindex $bbox 0]\n"
7527 "set x2 [lindex $bbox 2]\n"
7528 "incr x1 -[expr {$pad * 2}]\n"
7529 "incr x2 -[expr {$pad * 1}] ; # *1 ?\n"
7530 "set cW [expr {[winfo width $data(canvas)] - $pad*2}]\n"
7531 "set scrollW [expr {[lindex $sRegion 2]-[lindex $sRegion 0]+1}]\n"
7532 "set dispX [expr {int([lindex [$data(canvas) xview] 0]*$scrollW)}]\n"
7533 "set oldDispX $dispX\n"
7534 "if {($x2 - $dispX) >= $cW} {\n"
7535 "set dispX [expr {$x2 - $cW}]\n"
7536 "}\n"
7537 "if {($x1 - $dispX) < 0} {\n"
7538 "set dispX $x1\n"
7539 "}\n"
7540 "if {$oldDispX != $dispX} {\n"
7541 "set fraction [expr {double($dispX)/double($scrollW)}]\n"
7542 "$data(canvas) xview moveto $fraction\n"
7543 "}\n"
7544 "}\n"
7545 "proc tkIconList_SelectAtXY {w x y} {\n"
7546 "upvar #0 $w data\n"
7547 "tkIconList_Select $w [$data(canvas) find closest \\\n"
7548 "\011 [$data(canvas) canvasx $x] [$data(canvas) canvasy $y]]\n"
7549 "}\n"
7550 "proc tkIconList_Select {w rTag {callBrowse 1}} {\n"
7551 "upvar #0 $w data\n"
7552 "upvar #0 $w:itemList itemList\n"
7553 "if {![info exists itemList($rTag)]} {\n"
7554 "return\n"
7555 "}\n"
7556 "set iTag [lindex $itemList($rTag) 0]\n"
7557 "set tTag [lindex $itemList($rTag) 1]\n"
7558 "set text [lindex $itemList($rTag) 2]\n"
7559 "set serial [lindex $itemList($rTag) 3]\n"
7560 "if {![info exists data(rect)]} {\n"
7561 "set data(rect) [$data(canvas) create rect 0 0 0 0 \\\n"
7562 "\011\011-fill #a0a0ff -outline #a0a0ff]\n"
7563 "}\n"
7564 "$data(canvas) lower $data(rect)\n"
7565 "set bbox [$data(canvas) bbox $tTag]\n"
7566 "eval [list $data(canvas) coords $data(rect)] $bbox\n"
7567 "set data(curItem) $serial\n"
7568 "set data(selected) $text\n"
7569 "if {$callBrowse && $data(-browsecmd) != \"\"} {\n"
7570 "eval $data(-browsecmd) [list $text]\n"
7571 "}\n"
7572 "}\n"
7573 "proc tkIconList_Unselect {w} {\n"
7574 "upvar #0 $w data\n"
7575 "if {[info exists data(rect)]} {\n"
7576 "$data(canvas) delete $data(rect)\n"
7577 "unset data(rect)\n"
7578 "}\n"
7579 "if {[info exists data(selected)]} {\n"
7580 "unset data(selected)\n"
7581 "}\n"
7582 "#set data(curItem) {}\n"
7583 "}\n"
7584 "proc tkIconList_Get {w} {\n"
7585 "upvar #0 $w data\n"
7586 "if {[info exists data(selected)]} {\n"
7587 "return $data(selected)\n"
7588 "} else {\n"
7589 "return \"\"\n"
7590 "}\n"
7591 "}\n"
7592 "proc tkIconList_Btn1 {w x y} {\n"
7593 "upvar #0 $w data\n"
7594 "focus $data(canvas)\n"
7595 "tkIconList_SelectAtXY $w $x $y\n"
7596 "}\n"
7597 "proc tkIconList_Motion1 {w x y} {\n"
7598 "global tkPriv\n"
7599 "set tkPriv(x) $x\n"
7600 "set tkPriv(y) $y\n"
7601 "tkIconList_SelectAtXY $w $x $y\n"
7602 "}\n"
7603 "proc tkIconList_Double1 {w x y} {\n"
7604 "upvar #0 $w data\n"
7605 "if {[string compare $data(curItem) {}]} {\n"
7606 "tkIconList_Invoke $w\n"
7607 "}\n"
7608 "}\n"
7609 "proc tkIconList_ReturnKey {w} {\n"
7610 "tkIconList_Invoke $w\n"
7611 "}\n"
7612 "proc tkIconList_Leave1 {w x y} {\n"
7613 "global tkPriv\n"
7614 "set tkPriv(x) $x\n"
7615 "set tkPriv(y) $y\n"
7616 "tkIconList_AutoScan $w\n"
7617 "}\n"
7618 "proc tkIconList_FocusIn {w} {\n"
7619 "upvar #0 $w data\n"
7620 "if {![info exists data(list)]} {\n"
7621 "return\n"
7622 "}\n"
7623 "if {[string compare $data(curItem) {}]} {\n"
7624 "tkIconList_Select $w [lindex [lindex $data(list) $data(curItem)] 2] 1\n"
7625 "}\n"
7626 "}\n"
7627 "proc tkIconList_UpDown {w amount} {\n"
7628 "upvar #0 $w data\n"
7629 "if {![info exists data(list)]} {\n"
7630 "return\n"
7631 "}\n"
7632 "if {[string equal $data(curItem) {}]} {\n"
7633 "set rTag [lindex [lindex $data(list) 0] 2]\n"
7634 "} else {\n"
7635 "set oldRTag [lindex [lindex $data(list) $data(curItem)] 2]\n"
7636 "set rTag [lindex [lindex $data(list) [expr {$data(curItem)+$amount}]] 2]\n"
7637 "if {[string equal $rTag \"\"]} {\n"
7638 "set rTag $oldRTag\n"
7639 "}\n"
7640 "}\n"
7641 "if {[string compare $rTag \"\"]} {\n"
7642 "tkIconList_Select $w $rTag\n"
7643 "tkIconList_See $w $rTag\n"
7644 "}\n"
7645 "}\n"
7646 "proc tkIconList_LeftRight {w amount} {\n"
7647 "upvar #0 $w data\n"
7648 "if {![info exists data(list)]} {\n"
7649 "return\n"
7650 "}\n"
7651 "if {[string equal $data(curItem) {}]} {\n"
7652 "set rTag [lindex [lindex $data(list) 0] 2]\n"
7653 "} else {\n"
7654 "set oldRTag [lindex [lindex $data(list) $data(curItem)] 2]\n"
7655 "set newItem [expr {$data(curItem)+($amount*$data(itemsPerColumn))}]\n"
7656 "set rTag [lindex [lindex $data(list) $newItem] 2]\n"
7657 "if {[string equal $rTag \"\"]} {\n"
7658 "set rTag $oldRTag\n"
7659 "}\n"
7660 "}\n"
7661 "if {[string compare $rTag \"\"]} {\n"
7662 "tkIconList_Select $w $rTag\n"
7663 "tkIconList_See $w $rTag\n"
7664 "}\n"
7665 "}\n"
7666 "proc tkIconList_KeyPress {w key} {\n"
7667 "global tkPriv\n"
7668 "append tkPriv(ILAccel,$w) $key\n"
7669 "tkIconList_Goto $w $tkPriv(ILAccel,$w)\n"
7670 "catch {\n"
7671 "after cancel $tkPriv(ILAccel,$w,afterId)\n"
7672 "}\n"
7673 "set tkPriv(ILAccel,$w,afterId) [after 500 [list tkIconList_Reset $w]]\n"
7674 "}\n"
7675 "proc tkIconList_Goto {w text} {\n"
7676 "upvar #0 $w data\n"
7677 "upvar #0 $w:textList textList\n"
7678 "global tkPriv\n"
7679 "if {![info exists data(list)]} {\n"
7680 "return\n"
7681 "}\n"
7682 "if {[string equal {} $text]} {\n"
7683 "return\n"
7684 "}\n"
7685 "if {$data(curItem) == \"\" || $data(curItem) == 0} {\n"
7686 "set start 0\n"
7687 "} else {\n"
7688 "set start $data(curItem)\n"
7689 "}\n"
7690 "set text [string tolower $text]\n"
7691 "set theIndex -1\n"
7692 "set less 0\n"
7693 "set len [string length $text]\n"
7694 "set len0 [expr {$len-1}]\n"
7695 "set i $start\n"
7696 "while {1} {\n"
7697 "set sub [string range $textList($i) 0 $len0]\n"
7698 "if {[string equal $text $sub]} {\n"
7699 "set theIndex $i\n"
7700 "break\n"
7701 "}\n"
7702 "incr i\n"
7703 "if {$i == $data(numItems)} {\n"
7704 "set i 0\n"
7705 "}\n"
7706 "if {$i == $start} {\n"
7707 "break\n"
7708 "}\n"
7709 "}\n"
7710 "if {$theIndex > -1} {\n"
7711 "set rTag [lindex [lindex $data(list) $theIndex] 2]\n"
7712 "tkIconList_Select $w $rTag\n"
7713 "tkIconList_See $w $rTag\n"
7714 "}\n"
7715 "}\n"
7716 "proc tkIconList_Reset {w} {\n"
7717 "global tkPriv\n"
7718 "catch {unset tkPriv(ILAccel,$w)}\n"
7719 "}\n"
7720 "namespace eval ::tk::dialog {}\n"
7721 "namespace eval ::tk::dialog::file {}\n"
7722 "proc ::tk::dialog::file::tkFDialog {type args} {\n"
7723 "global tkPriv\n"
7724 "set dataName __tk_filedialog\n"
7725 "upvar ::tk::dialog::file::$dataName data\n"
7726 "::tk::dialog::file::Config $dataName $type $args\n"
7727 "if {[string equal $data(-parent) .]} {\n"
7728 "set w .$dataName\n"
7729 "} else {\n"
7730 "set w $data(-parent).$dataName\n"
7731 "}\n"
7732 "if {![winfo exists $w]} {\n"
7733 "::tk::dialog::file::Create $w TkFDialog\n"
7734 "} elseif {[string compare [winfo class $w] TkFDialog]} {\n"
7735 "destroy $w\n"
7736 "::tk::dialog::file::Create $w TkFDialog\n"
7737 "} else {\n"
7738 "set data(dirMenuBtn) $w.f1.menu\n"
7739 "set data(dirMenu) $w.f1.menu.menu\n"
7740 "set data(upBtn) $w.f1.up\n"
7741 "set data(icons) $w.icons\n"
7742 "set data(ent) $w.f2.ent\n"
7743 "set data(typeMenuLab) $w.f3.lab\n"
7744 "set data(typeMenuBtn) $w.f3.menu\n"
7745 "set data(typeMenu) $data(typeMenuBtn).m\n"
7746 "set data(okBtn) $w.f2.ok\n"
7747 "set data(cancelBtn) $w.f3.cancel\n"
7748 "}\n"
7749 "wm transient $w $data(-parent)\n"
7750 "trace variable data(selectPath) w \"::tk::dialog::file::SetPath $w\"\n"
7751 "$data(dirMenuBtn) configure \\\n"
7752 "\011 -textvariable ::tk::dialog::file::${dataName}(selectPath)\n"
7753 "if {[llength $data(-filetypes)]} {\n"
7754 "$data(typeMenu) delete 0 end\n"
7755 "foreach type $data(-filetypes) {\n"
7756 "set title [lindex $type 0]\n"
7757 "set filter [lindex $type 1]\n"
7758 "$data(typeMenu) add command -label $title \\\n"
7759 "\011\011-command [list ::tk::dialog::file::SetFilter $w $type]\n"
7760 "}\n"
7761 "::tk::dialog::file::SetFilter $w [lindex $data(-filetypes) 0]\n"
7762 "$data(typeMenuBtn) config -state normal\n"
7763 "$data(typeMenuLab) config -state normal\n"
7764 "} else {\n"
7765 "set data(filter) \"*\"\n"
7766 "$data(typeMenuBtn) config -state disabled -takefocus 0\n"
7767 "$data(typeMenuLab) config -state disabled\n"
7768 "}\n"
7769 "::tk::dialog::file::UpdateWhenIdle $w\n"
7770 "::tk::PlaceWindow $w widget $data(-parent)\n"
7771 "wm title $w $data(-title)\n"
7772 "::tk::SetFocusGrab $w $data(ent)\n"
7773 "$data(ent) delete 0 end\n"
7774 "$data(ent) insert 0 $data(selectFile)\n"
7775 "$data(ent) selection range 0 end\n"
7776 "$data(ent) icursor end\n"
7777 "tkwait variable tkPriv(selectFilePath)\n"
7778 "::tk::RestoreFocusGrab $w $data(ent) withdraw\n"
7779 "foreach trace [trace vinfo data(selectPath)] {\n"
7780 "trace vdelete data(selectPath) [lindex $trace 0] [lindex $trace 1]\n"
7781 "}\n"
7782 "$data(dirMenuBtn) configure -textvariable {}\n"
7783 "return $tkPriv(selectFilePath)\n"
7784 "}\n"
7785 "proc ::tk::dialog::file::Config {dataName type argList} {\n"
7786 "upvar ::tk::dialog::file::$dataName data\n"
7787 "set data(type) $type\n"
7788 "foreach trace [trace vinfo data(selectPath)] {\n"
7789 "trace vdelete data(selectPath) [lindex $trace 0] [lindex $trace 1]\n"
7790 "}\n"
7791 "set specs {\n"
7792 "{-defaultextension \"\" \"\" \"\"}\n"
7793 "{-filetypes \"\" \"\" \"\"}\n"
7794 "{-initialdir \"\" \"\" \"\"}\n"
7795 "{-initialfile \"\" \"\" \"\"}\n"
7796 "{-parent \"\" \"\" \".\"}\n"
7797 "{-title \"\" \"\" \"\"}\n"
7798 "}\n"
7799 "if {![info exists data(selectPath)]} {\n"
7800 "set data(selectPath) [pwd]\n"
7801 "set data(selectFile) \"\"\n"
7802 "}\n"
7803 "tclParseConfigSpec ::tk::dialog::file::$dataName $specs \"\" $argList\n"
7804 "if {$data(-title) == \"\"} {\n"
7805 "if {[string equal $type \"open\"]} {\n"
7806 "set data(-title) \"Open\"\n"
7807 "} else {\n"
7808 "set data(-title) \"Save As\"\n"
7809 "}\n"
7810 "}\n"
7811 "if {$data(-initialdir) != \"\"} {\n"
7812 "if {[file isdirectory $data(-initialdir)]} {\n"
7813 "set old [pwd]\n"
7814 "cd $data(-initialdir)\n"
7815 "set data(selectPath) [pwd]\n"
7816 "cd $old\n"
7817 "} else {\n"
7818 "set data(selectPath) [pwd]\n"
7819 "}\n"
7820 "}\n"
7821 "set data(selectFile) $data(-initialfile)\n"
7822 "set data(-filetypes) [tkFDGetFileTypes $data(-filetypes)]\n"
7823 "if {![winfo exists $data(-parent)]} {\n"
7824 "error \"bad window path name \\\"$data(-parent)\\\"\"\n"
7825 "}\n"
7826 "}\n"
7827 "proc ::tk::dialog::file::Create {w class} {\n"
7828 "set dataName [lindex [split $w .] end]\n"
7829 "upvar ::tk::dialog::file::$dataName data\n"
7830 "global tk_library tkPriv\n"
7831 "toplevel $w -class $class\n"
7832 "set f1 [frame $w.f1]\n"
7833 "label $f1.lab -text \"Directory:\" -under 0\n"
7834 "set data(dirMenuBtn) $f1.menu\n"
7835 "set data(dirMenu) [tk_optionMenu $f1.menu [format %s(selectPath) ::tk::dialog::file::$dataName] \"\"]\n"
7836 "set data(upBtn) [button $f1.up]\n"
7837 "if {![info exists tkPriv(updirImage)]} {\n"
7838 "set tkPriv(updirImage) [image create bitmap -data {\n"
7839 "#define updir_width 28\n"
7840 "#define updir_height 16\n"
7841 "static char updir_bits[] = {\n"
7842 "0x00, 0x00, 0x00, 0x00, 0x80, 0x1f, 0x00, 0x00, 0x40, 0x20, 0x00, 0x00,\n"
7843 "0x20, 0x40, 0x00, 0x00, 0xf0, 0xff, 0xff, 0x01, 0x10, 0x00, 0x00, 0x01,\n"
7844 "0x10, 0x02, 0x00, 0x01, 0x10, 0x07, 0x00, 0x01, 0x90, 0x0f, 0x00, 0x01,\n"
7845 "0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01,\n"
7846 "0x10, 0xfe, 0x07, 0x01, 0x10, 0x00, 0x00, 0x01, 0x10, 0x00, 0x00, 0x01,\n"
7847 "0xf0, 0xff, 0xff, 0x01};}]\n"
7848 "}\n"
7849 "$data(upBtn) config -image $tkPriv(updirImage)\n"
7850 "$f1.menu config -takefocus 1 -highlightthickness 2\n"
7851 "pack $data(upBtn) -side right -padx 4 -fill both\n"
7852 "pack $f1.lab -side left -padx 4 -fill both\n"
7853 "pack $f1.menu -expand yes -fill both -padx 4\n"
7854 "if { [string equal $class TkFDialog] } {\n"
7855 "set fNameCaption \"File name:\"\n"
7856 "set fNameUnder 5\n"
7857 "set iconListCommand [list ::tk::dialog::file::OkCmd $w]\n"
7858 "} else {\n"
7859 "set fNameCaption \"Selection:\"\n"
7860 "set fNameUnder 0\n"
7861 "set iconListCommand [list ::tk::dialog::file::chooseDir::DblClick $w]\n"
7862 "}\n"
7863 "set data(icons) [tkIconList $w.icons \\\n"
7864 "\011-browsecmd [list ::tk::dialog::file::ListBrowse $w] \\\n"
7865 "\011-command $iconListCommand]\n"
7866 "set f2 [frame $w.f2 -bd 0]\n"
7867 "label $f2.lab -text $fNameCaption -anchor e -width 14 \\\n"
7868 "\011 -under $fNameUnder -pady 0\n"
7869 "set data(ent) [entry $f2.ent]\n"
7870 "global $w.icons\n"
7871 "set $w.icons(font) [$data(ent) cget -font]\n"
7872 "set f3 [frame $w.f3 -bd 0]\n"
7873 "if { [string equal $class TkFDialog] } {\n"
7874 "set data(typeMenuLab) [button $f3.lab -text \"Files of type:\" \\\n"
7875 "\011\011-anchor e -width 14 -under 9 \\\n"
7876 "\011\011-bd [$f2.lab cget -bd] \\\n"
7877 "\011\011-highlightthickness [$f2.lab cget -highlightthickness] \\\n"
7878 "\011\011-relief [$f2.lab cget -relief] \\\n"
7879 "\011\011-padx [$f2.lab cget -padx] \\\n"
7880 "\011\011-pady [$f2.lab cget -pady]]\n"
7881 "bindtags $data(typeMenuLab) [list $data(typeMenuLab) Label \\\n"
7882 "\011\011[winfo toplevel $data(typeMenuLab)] all]\n"
7883 "set data(typeMenuBtn) [menubutton $f3.menu -indicatoron 1 \\\n"
7884 "\011\011-menu $f3.menu.m]\n"
7885 "set data(typeMenu) [menu $data(typeMenuBtn).m -tearoff 0]\n"
7886 "$data(typeMenuBtn) config -takefocus 1 -highlightthickness 2 \\\n"
7887 "\011\011-relief raised -bd 2 -anchor w\n"
7888 "}\n"
7889 "set data(okBtn) [button $f2.ok -text OK -under 0 -width 6 \\\n"
7890 "\011-default active -pady 3]\n"
7891 "set data(cancelBtn) [button $f3.cancel -text Cancel -under 0 -width 6\\\n"
7892 "\011-default normal -pady 3]\n"
7893 "pack $data(okBtn) -side right -padx 4 -anchor e\n"
7894 "pack $f2.lab -side left -padx 4\n"
7895 "pack $f2.ent -expand yes -fill x -padx 2 -pady 0\n"
7896 "pack $data(cancelBtn) -side right -padx 4 -anchor w\n"
7897 "if { [string equal $class TkFDialog] } {\n"
7898 "pack $data(typeMenuLab) -side left -padx 4\n"
7899 "pack $data(typeMenuBtn) -expand yes -fill x -side right\n"
7900 "}\n"
7901 "pack $f1 -side top -fill x -pady 4\n"
7902 "pack $f3 -side bottom -fill x\n"
7903 "pack $f2 -side bottom -fill x\n"
7904 "pack $data(icons) -expand yes -fill both -padx 4 -pady 1\n"
7905 "wm protocol $w WM_DELETE_WINDOW [list ::tk::dialog::file::CancelCmd $w]\n"
7906 "$data(upBtn) config -command [list ::tk::dialog::file::UpDirCmd $w]\n"
7907 "$data(cancelBtn) config -command [list ::tk::dialog::file::CancelCmd $w]\n"
7908 "bind $w <KeyPress-Escape> [list tkButtonInvoke $data(cancelBtn)]\n"
7909 "bind $w <Alt-c> [list tkButtonInvoke $data(cancelBtn)]\n"
7910 "bind $w <Alt-d> [list focus $data(dirMenuBtn)]\n"
7911 "if { [string equal $class TkFDialog] } {\n"
7912 "bind $data(ent) <Return> [list ::tk::dialog::file::ActivateEnt $w]\n"
7913 "$data(okBtn) config -command [list ::tk::dialog::file::OkCmd $w]\n"
7914 "bind $w <Alt-t> [format {\n"
7915 "if {[string equal [%s cget -state] \"normal\"]} {\n"
7916 "focus %s\n"
7917 "}\n"
7918 "} $data(typeMenuBtn) $data(typeMenuBtn)]\n"
7919 "bind $w <Alt-n> [list focus $data(ent)]\n"
7920 "bind $w <Alt-o> [list ::tk::dialog::file::InvokeBtn $w Open]\n"
7921 "bind $w <Alt-s> [list ::tk::dialog::file::InvokeBtn $w Save]\n"
7922 "} else {\n"
7923 "set okCmd [list ::tk::dialog::file::chooseDir::OkCmd $w]\n"
7924 "bind $data(ent) <Return> $okCmd\n"
7925 "$data(okBtn) config -command $okCmd\n"
7926 "bind $w <Alt-s> [list focus $data(ent)]\n"
7927 "bind $w <Alt-o> [list tkButtonInvoke $data(okBtn)]\n"
7928 "}\n"
7929 "tkFocusGroup_Create $w\n"
7930 "tkFocusGroup_BindIn $w $data(ent) [list ::tk::dialog::file::EntFocusIn $w]\n"
7931 "tkFocusGroup_BindOut $w $data(ent) [list ::tk::dialog::file::EntFocusOut $w]\n"
7932 "}\n"
7933 "proc ::tk::dialog::file::UpdateWhenIdle {w} {\n"
7934 "upvar ::tk::dialog::file::[winfo name $w] data\n"
7935 "if {[info exists data(updateId)]} {\n"
7936 "return\n"
7937 "} else {\n"
7938 "set data(updateId) [after idle [list ::tk::dialog::file::Update $w]]\n"
7939 "}\n"
7940 "}\n"
7941 "proc ::tk::dialog::file::Update {w} {\n"
7942 "if {![winfo exists $w]} {\n"
7943 "return\n"
7944 "}\n"
7945 "set class [winfo class $w]\n"
7946 "if { [string compare $class TkFDialog] && \\\n"
7947 "\011 [string compare $class TkChooseDir] } {\n"
7948 "return\n"
7949 "}\n"
7950 "set dataName [winfo name $w]\n"
7951 "upvar ::tk::dialog::file::$dataName data\n"
7952 "global tk_library tkPriv\n"
7953 "catch {unset data(updateId)}\n"
7954 "if {![info exists tkPriv(folderImage)]} {\n"
7955 "set tkPriv(folderImage) [image create photo -data {\n"
7956 "R0lGODlhEAAMAKEAAAD//wAAAPD/gAAAACH5BAEAAAAALAAAAAAQAAwAAAIghINhyycvVFsB\n"
7957 "QtmS3rjaH1Hg141WaT5ouprt2HHcUgAAOw==}]\n"
7958 "set tkPriv(fileImage) [image create photo -data {\n"
7959 "R0lGODlhDAAMAKEAALLA3AAAAP//8wAAACH5BAEAAAAALAAAAAAMAAwAAAIgRI4Ha+IfWHsO\n"
7960 "rSASvJTGhnhcV3EJlo3kh53ltF5nAhQAOw==}]\n"
7961 "}\n"
7962 "set folder $tkPriv(folderImage)\n"
7963 "set file $tkPriv(fileImage)\n"
7964 "set appPWD [pwd]\n"
7965 "if {[catch {\n"
7966 "cd $data(selectPath)\n"
7967 "}]} {\n"
7968 "tk_messageBox -type ok -parent $w -message \\\n"
7969 "\011 \"Cannot change to the directory \\\"$data(selectPath)\\\".\\nPermission denied.\"\\\n"
7970 "\011 -icon warning\n"
7971 "cd $appPWD\n"
7972 "return\n"
7973 "}\n"
7974 "set entCursor [$data(ent) cget -cursor]\n"
7975 "set dlgCursor [$w cget -cursor]\n"
7976 "$data(ent) config -cursor watch\n"
7977 "$w config -cursor watch\n"
7978 "update idletasks\n"
7979 "tkIconList_DeleteAll $data(icons)\n"
7980 "foreach f [lsort -dictionary [glob -nocomplain .* *]] {\n"
7981 "if {[string equal $f .]} {\n"
7982 "continue\n"
7983 "}\n"
7984 "if {[string equal $f ..]} {\n"
7985 "continue\n"
7986 "}\n"
7987 "if {[file isdir ./$f]} {\n"
7988 "if {![info exists hasDoneDir($f)]} {\n"
7989 "tkIconList_Add $data(icons) $folder $f\n"
7990 "set hasDoneDir($f) 1\n"
7991 "}\n"
7992 "}\n"
7993 "}\n"
7994 "if { [string equal $class TkFDialog] } {\n"
7995 "if {[string equal $data(filter) *]} {\n"
7996 "set files [lsort -dictionary \\\n"
7997 "\011\011 [glob -nocomplain .* *]]\n"
7998 "} else {\n"
7999 "set files [lsort -dictionary \\\n"
8000 "\011\011 [eval glob -nocomplain $data(filter)]]\n"
8001 "}\n"
8002 "foreach f $files {\n"
8003 "if {![file isdir ./$f]} {\n"
8004 "if {![info exists hasDoneFile($f)]} {\n"
8005 "tkIconList_Add $data(icons) $file $f\n"
8006 "set hasDoneFile($f) 1\n"
8007 "}\n"
8008 "}\n"
8009 "}\n"
8010 "}\n"
8011 "tkIconList_Arrange $data(icons)\n"
8012 "set list \"\"\n"
8013 "set dir \"\"\n"
8014 "foreach subdir [file split $data(selectPath)] {\n"
8015 "set dir [file join $dir $subdir]\n"
8016 "lappend list $dir\n"
8017 "}\n"
8018 "$data(dirMenu) delete 0 end\n"
8019 "set var [format %s(selectPath) ::tk::dialog::file::$dataName]\n"
8020 "foreach path $list {\n"
8021 "$data(dirMenu) add command -label $path -command [list set $var $path]\n"
8022 "}\n"
8023 "cd $appPWD\n"
8024 "if { [string equal $class TkFDialog] } {\n"
8025 "if {[string equal $data(type) open]} {\n"
8026 "$data(okBtn) config -text \"Open\"\n"
8027 "} else {\n"
8028 "$data(okBtn) config -text \"Save\"\n"
8029 "}\n"
8030 "}\n"
8031 "$data(ent) config -cursor $entCursor\n"
8032 "$w config -cursor $dlgCursor\n"
8033 "}\n"
8034 "proc ::tk::dialog::file::SetPathSilently {w path} {\n"
8035 "upvar ::tk::dialog::file::[winfo name $w] data\n"
8036 "trace vdelete data(selectPath) w [list ::tk::dialog::file::SetPath $w]\n"
8037 "set data(selectPath) $path\n"
8038 "trace variable data(selectPath) w [list ::tk::dialog::file::SetPath $w]\n"
8039 "}\n"
8040 "proc ::tk::dialog::file::SetPath {w name1 name2 op} {\n"
8041 "if {[winfo exists $w]} {\n"
8042 "upvar ::tk::dialog::file::[winfo name $w] data\n"
8043 "::tk::dialog::file::UpdateWhenIdle $w\n"
8044 "if { [string equal [winfo class $w] TkChooseDir] } {\n"
8045 "$data(ent) delete 0 end\n"
8046 "$data(ent) insert end $data(selectPath)\n"
8047 "}\n"
8048 "}\n"
8049 "}\n"
8050 "proc ::tk::dialog::file::SetFilter {w type} {\n"
8051 "upvar ::tk::dialog::file::[winfo name $w] data\n"
8052 "upvar \\#0 $data(icons) icons\n"
8053 "set data(filter) [lindex $type 1]\n"
8054 "$data(typeMenuBtn) config -text [lindex $type 0] -indicatoron 1\n"
8055 "$icons(sbar) set 0.0 0.0\n"
8056 "::tk::dialog::file::UpdateWhenIdle $w\n"
8057 "}\n"
8058 "proc ::tk::dialog::file::ResolveFile {context text defaultext} {\n"
8059 "set appPWD [pwd]\n"
8060 "set path [::tk::dialog::file::JoinFile $context $text]\n"
8061 "if {![file isdirectory $path] && [string equal [file ext $path] \"\"]} {\n"
8062 "set path \"$path$defaultext\"\n"
8063 "}\n"
8064 "if {[catch {file exists $path}]} {\n"
8065 "return [list ERROR $path \"\"]\n"
8066 "}\n"
8067 "if {[file exists $path]} {\n"
8068 "if {[file isdirectory $path]} {\n"
8069 "if {[catch {cd $path}]} {\n"
8070 "return [list CHDIR $path \"\"]\n"
8071 "}\n"
8072 "set directory [pwd]\n"
8073 "set file \"\"\n"
8074 "set flag OK\n"
8075 "cd $appPWD\n"
8076 "} else {\n"
8077 "if {[catch {cd [file dirname $path]}]} {\n"
8078 "return [list CHDIR [file dirname $path] \"\"]\n"
8079 "}\n"
8080 "set directory [pwd]\n"
8081 "set file [file tail $path]\n"
8082 "set flag OK\n"
8083 "cd $appPWD\n"
8084 "}\n"
8085 "} else {\n"
8086 "set dirname [file dirname $path]\n"
8087 "if {[file exists $dirname]} {\n"
8088 "if {[catch {cd $dirname}]} {\n"
8089 "return [list CHDIR $dirname \"\"]\n"
8090 "}\n"
8091 "set directory [pwd]\n"
8092 "set file [file tail $path]\n"
8093 "if {[regexp {[*]|[?]} $file]} {\n"
8094 "set flag PATTERN\n"
8095 "} else {\n"
8096 "set flag FILE\n"
8097 "}\n"
8098 "cd $appPWD\n"
8099 "} else {\n"
8100 "set directory $dirname\n"
8101 "set file [file tail $path]\n"
8102 "set flag PATH\n"
8103 "}\n"
8104 "}\n"
8105 "return [list $flag $directory $file]\n"
8106 "}\n"
8107 "proc ::tk::dialog::file::EntFocusIn {w} {\n"
8108 "upvar ::tk::dialog::file::[winfo name $w] data\n"
8109 "if {[string compare [$data(ent) get] \"\"]} {\n"
8110 "$data(ent) selection range 0 end\n"
8111 "$data(ent) icursor end\n"
8112 "} else {\n"
8113 "$data(ent) selection clear\n"
8114 "}\n"
8115 "tkIconList_Unselect $data(icons)\n"
8116 "if { [string equal [winfo class $w] TkFDialog] } {\n"
8117 "if {[string equal $data(type) open]} {\n"
8118 "$data(okBtn) config -text \"Open\"\n"
8119 "} else {\n"
8120 "$data(okBtn) config -text \"Save\"\n"
8121 "}\n"
8122 "}\n"
8123 "}\n"
8124 "proc ::tk::dialog::file::EntFocusOut {w} {\n"
8125 "upvar ::tk::dialog::file::[winfo name $w] data\n"
8126 "$data(ent) selection clear\n"
8127 "}\n"
8128 "proc ::tk::dialog::file::ActivateEnt {w} {\n"
8129 "upvar ::tk::dialog::file::[winfo name $w] data\n"
8130 "set text [string trim [$data(ent) get]]\n"
8131 "set list [::tk::dialog::file::ResolveFile $data(selectPath) $text \\\n"
8132 "\011\011 $data(-defaultextension)]\n"
8133 "set flag [lindex $list 0]\n"
8134 "set path [lindex $list 1]\n"
8135 "set file [lindex $list 2]\n"
8136 "switch -- $flag {\n"
8137 "OK {\n"
8138 "if {[string equal $file \"\"]} {\n"
8139 "set data(selectPath) $path\n"
8140 "$data(ent) delete 0 end\n"
8141 "} else {\n"
8142 "::tk::dialog::file::SetPathSilently $w $path\n"
8143 "set data(selectFile) $file\n"
8144 "::tk::dialog::file::Done $w\n"
8145 "}\n"
8146 "}\n"
8147 "PATTERN {\n"
8148 "set data(selectPath) $path\n"
8149 "set data(filter) $file\n"
8150 "}\n"
8151 "FILE {\n"
8152 "if {[string equal $data(type) open]} {\n"
8153 "tk_messageBox -icon warning -type ok -parent $w \\\n"
8154 "\011\011 -message \"File \\\"[file join $path $file]\\\" does not exist.\"\n"
8155 "$data(ent) selection range 0 end\n"
8156 "$data(ent) icursor end\n"
8157 "} else {\n"
8158 "::tk::dialog::file::SetPathSilently $w $path\n"
8159 "set data(selectFile) $file\n"
8160 "::tk::dialog::file::Done $w\n"
8161 "}\n"
8162 "}\n"
8163 "PATH {\n"
8164 "tk_messageBox -icon warning -type ok -parent $w \\\n"
8165 "\011\011-message \"Directory \\\"$path\\\" does not exist.\"\n"
8166 "$data(ent) selection range 0 end\n"
8167 "$data(ent) icursor end\n"
8168 "}\n"
8169 "CHDIR {\n"
8170 "tk_messageBox -type ok -parent $w -message \\\n"
8171 "\011 \"Cannot change to the directory \\\"$path\\\".\\nPermission denied.\"\\\n"
8172 "\011\011-icon warning\n"
8173 "$data(ent) selection range 0 end\n"
8174 "$data(ent) icursor end\n"
8175 "}\n"
8176 "ERROR {\n"
8177 "tk_messageBox -type ok -parent $w -message \\\n"
8178 "\011 \"Invalid file name \\\"$path\\\".\"\\\n"
8179 "\011\011-icon warning\n"
8180 "$data(ent) selection range 0 end\n"
8181 "$data(ent) icursor end\n"
8182 "}\n"
8183 "}\n"
8184 "}\n"
8185 "proc ::tk::dialog::file::InvokeBtn {w key} {\n"
8186 "upvar ::tk::dialog::file::[winfo name $w] data\n"
8187 "if {[string equal [$data(okBtn) cget -text] $key]} {\n"
8188 "tkButtonInvoke $data(okBtn)\n"
8189 "}\n"
8190 "}\n"
8191 "proc ::tk::dialog::file::UpDirCmd {w} {\n"
8192 "upvar ::tk::dialog::file::[winfo name $w] data\n"
8193 "if {[string compare $data(selectPath) \"/\"]} {\n"
8194 "set data(selectPath) [file dirname $data(selectPath)]\n"
8195 "}\n"
8196 "}\n"
8197 "proc ::tk::dialog::file::JoinFile {path file} {\n"
8198 "if {[string match {~*} $file] && [file exists $path/$file]} {\n"
8199 "return [file join $path ./$file]\n"
8200 "} else {\n"
8201 "return [file join $path $file]\n"
8202 "}\n"
8203 "}\n"
8204 "proc ::tk::dialog::file::OkCmd {w} {\n"
8205 "upvar ::tk::dialog::file::[winfo name $w] data\n"
8206 "set text [tkIconList_Get $data(icons)]\n"
8207 "if {[string compare $text \"\"]} {\n"
8208 "set file [::tk::dialog::file::JoinFile $data(selectPath) $text]\n"
8209 "if {[file isdirectory $file]} {\n"
8210 "::tk::dialog::file::ListInvoke $w $text\n"
8211 "return\n"
8212 "}\n"
8213 "}\n"
8214 "::tk::dialog::file::ActivateEnt $w\n"
8215 "}\n"
8216 "proc ::tk::dialog::file::CancelCmd {w} {\n"
8217 "upvar ::tk::dialog::file::[winfo name $w] data\n"
8218 "global tkPriv\n"
8219 "set tkPriv(selectFilePath) \"\"\n"
8220 "}\n"
8221 "proc ::tk::dialog::file::ListBrowse {w text} {\n"
8222 "upvar ::tk::dialog::file::[winfo name $w] data\n"
8223 "if {[string equal $text \"\"]} {\n"
8224 "return\n"
8225 "}\n"
8226 "set file [::tk::dialog::file::JoinFile $data(selectPath) $text]\n"
8227 "if {![file isdirectory $file]} {\n"
8228 "$data(ent) delete 0 end\n"
8229 "$data(ent) insert 0 $text\n"
8230 "if { [string equal [winfo class $w] TkFDialog] } {\n"
8231 "if {[string equal $data(type) open]} {\n"
8232 "$data(okBtn) config -text \"Open\"\n"
8233 "} else {\n"
8234 "$data(okBtn) config -text \"Save\"\n"
8235 "}\n"
8236 "}\n"
8237 "} else {\n"
8238 "if { [string equal [winfo class $w] TkFDialog] } {\n"
8239 "$data(okBtn) config -text \"Open\"\n"
8240 "}\n"
8241 "}\n"
8242 "}\n"
8243 "proc ::tk::dialog::file::ListInvoke {w text} {\n"
8244 "upvar ::tk::dialog::file::[winfo name $w] data\n"
8245 "if {[string equal $text \"\"]} {\n"
8246 "return\n"
8247 "}\n"
8248 "set file [::tk::dialog::file::JoinFile $data(selectPath) $text]\n"
8249 "set class [winfo class $w]\n"
8250 "if {[string equal $class TkChooseDir] || [file isdirectory $file]} {\n"
8251 "set appPWD [pwd]\n"
8252 "if {[catch {cd $file}]} {\n"
8253 "tk_messageBox -type ok -parent $w -message \\\n"
8254 "\011 \"Cannot change to the directory \\\"$file\\\".\\nPermission denied.\"\\\n"
8255 "\011\011-icon warning\n"
8256 "} else {\n"
8257 "cd $appPWD\n"
8258 "set data(selectPath) $file\n"
8259 "}\n"
8260 "} else {\n"
8261 "set data(selectFile) $file\n"
8262 "::tk::dialog::file::Done $w\n"
8263 "}\n"
8264 "}\n"
8265 "proc ::tk::dialog::file::Done {w {selectFilePath \"\"}} {\n"
8266 "upvar ::tk::dialog::file::[winfo name $w] data\n"
8267 "global tkPriv\n"
8268 "if {[string equal $selectFilePath \"\"]} {\n"
8269 "set selectFilePath [::tk::dialog::file::JoinFile $data(selectPath) \\\n"
8270 "\011\011$data(selectFile)]\n"
8271 "set tkPriv(selectFile) $data(selectFile)\n"
8272 "set tkPriv(selectPath) $data(selectPath)\n"
8273 "if {[file exists $selectFilePath] && [string equal $data(type) save]} {\n"
8274 "set reply [tk_messageBox -icon warning -type yesno\\\n"
8275 "\011\011 -parent $w -message \"File\\\n"
8276 "\011\011 \\\"$selectFilePath\\\" already exists.\\nDo\\\n"
8277 "\011\011 you want to overwrite it?\"]\n"
8278 "if {[string equal $reply \"no\"]} {\n"
8279 "return\n"
8280 "}\n"
8281 "}\n"
8282 "}\n"
8283 "set tkPriv(selectFilePath) $selectFilePath\n"
8284 "}\n"
8285 ;
8286 static char Et_zFile30[] =
8287 "namespace eval ::tk::dialog {}\n"
8288 "namespace eval ::tk::dialog::file {}\n"
8289 "proc tkMotifFDialog {type args} {\n"
8290 "global tkPriv\n"
8291 "set dataName __tk_filedialog\n"
8292 "upvar ::tk::dialog::file::$dataName data\n"
8293 "set w [tkMotifFDialog_Create $dataName $type $args]\n"
8294 "::tk::SetFocusGrab $w $data(sEnt)\n"
8295 "$data(sEnt) selection range 0 end\n"
8296 "tkwait variable tkPriv(selectFilePath)\n"
8297 "::tk::RestoreFocusGrab $w $data(sEnt) withdraw\n"
8298 "return $tkPriv(selectFilePath)\n"
8299 "}\n"
8300 "proc tkMotifFDialog_Create {dataName type argList} {\n"
8301 "global tkPriv\n"
8302 "upvar ::tk::dialog::file::$dataName data\n"
8303 "tkMotifFDialog_Config $dataName $type $argList\n"
8304 "if {[string equal $data(-parent) .]} {\n"
8305 "set w .$dataName\n"
8306 "} else {\n"
8307 "set w $data(-parent).$dataName\n"
8308 "}\n"
8309 "if {![winfo exists $w]} {\n"
8310 "tkMotifFDialog_BuildUI $w\n"
8311 "} elseif {[string compare [winfo class $w] TkMotifFDialog]} {\n"
8312 "destroy $w\n"
8313 "tkMotifFDialog_BuildUI $w\n"
8314 "} else {\n"
8315 "set data(fEnt) $w.top.f1.ent\n"
8316 "set data(dList) $w.top.f2.a.l\n"
8317 "set data(fList) $w.top.f2.b.l\n"
8318 "set data(sEnt) $w.top.f3.ent\n"
8319 "set data(okBtn) $w.bot.ok\n"
8320 "set data(filterBtn) $w.bot.filter\n"
8321 "set data(cancelBtn) $w.bot.cancel\n"
8322 "}\n"
8323 "wm transient $w $data(-parent)\n"
8324 "tkMotifFDialog_Update $w\n"
8325 "::tk::PlaceWindow $w\n"
8326 "wm title $w $data(-title)\n"
8327 "return $w\n"
8328 "}\n"
8329 "proc tkMotifFDialog_Config {dataName type argList} {\n"
8330 "upvar ::tk::dialog::file::$dataName data\n"
8331 "set data(type) $type\n"
8332 "set specs {\n"
8333 "{-defaultextension \"\" \"\" \"\"}\n"
8334 "{-filetypes \"\" \"\" \"\"}\n"
8335 "{-initialdir \"\" \"\" \"\"}\n"
8336 "{-initialfile \"\" \"\" \"\"}\n"
8337 "{-parent \"\" \"\" \".\"}\n"
8338 "{-title \"\" \"\" \"\"}\n"
8339 "}\n"
8340 "if {![info exists data(selectPath)]} {\n"
8341 "set data(selectPath) [pwd]\n"
8342 "set data(selectFile) \"\"\n"
8343 "}\n"
8344 "tclParseConfigSpec ::tk::dialog::file::$dataName $specs \"\" $argList\n"
8345 "if {[string equal $data(-title) \"\"]} {\n"
8346 "if {[string equal $type \"open\"]} {\n"
8347 "set data(-title) \"Open\"\n"
8348 "} else {\n"
8349 "set data(-title) \"Save As\"\n"
8350 "}\n"
8351 "}\n"
8352 "if {[string compare $data(-initialdir) \"\"]} {\n"
8353 "if {[file isdirectory $data(-initialdir)]} {\n"
8354 "set data(selectPath) [glob $data(-initialdir)]\n"
8355 "} else {\n"
8356 "set data(selectPath) [pwd]\n"
8357 "}\n"
8358 "set old [pwd]\n"
8359 "cd $data(selectPath)\n"
8360 "set data(selectPath) [pwd]\n"
8361 "cd $old\n"
8362 "}\n"
8363 "set data(selectFile) $data(-initialfile)\n"
8364 "set data(-filetypes) [tkFDGetFileTypes $data(-filetypes)]\n"
8365 "if {![info exists data(filter)]} {\n"
8366 "set data(filter) *\n"
8367 "}\n"
8368 "if {![winfo exists $data(-parent)]} {\n"
8369 "error \"bad window path name \\\"$data(-parent)\\\"\"\n"
8370 "}\n"
8371 "}\n"
8372 "proc tkMotifFDialog_BuildUI {w} {\n"
8373 "set dataName [lindex [split $w .] end]\n"
8374 "upvar ::tk::dialog::file::$dataName data\n"
8375 "toplevel $w -class TkMotifFDialog\n"
8376 "set top [frame $w.top -relief raised -bd 1]\n"
8377 "set bot [frame $w.bot -relief raised -bd 1]\n"
8378 "pack $w.bot -side bottom -fill x\n"
8379 "pack $w.top -side top -expand yes -fill both\n"
8380 "set f1 [frame $top.f1]\n"
8381 "set f2 [frame $top.f2]\n"
8382 "set f3 [frame $top.f3]\n"
8383 "pack $f1 -side top -fill x\n"
8384 "pack $f3 -side bottom -fill x\n"
8385 "pack $f2 -expand yes -fill both\n"
8386 "set f2a [frame $f2.a]\n"
8387 "set f2b [frame $f2.b]\n"
8388 "grid $f2a -row 0 -column 0 -rowspan 1 -columnspan 1 -padx 4 -pady 4 \\\n"
8389 "\011-sticky news\n"
8390 "grid $f2b -row 0 -column 1 -rowspan 1 -columnspan 1 -padx 4 -pady 4 \\\n"
8391 "\011-sticky news\n"
8392 "grid rowconfig $f2 0 -minsize 0 -weight 1\n"
8393 "grid columnconfig $f2 0 -minsize 0 -weight 1\n"
8394 "grid columnconfig $f2 1 -minsize 150 -weight 2\n"
8395 "label $f1.lab -text \"Filter:\" -under 3 -anchor w\n"
8396 "entry $f1.ent\n"
8397 "pack $f1.lab -side top -fill x -padx 6 -pady 4\n"
8398 "pack $f1.ent -side top -fill x -padx 4 -pady 0\n"
8399 "set data(fEnt) $f1.ent\n"
8400 "set data(dList) [tkMotifFDialog_MakeSList $w $f2a Directory: 0 DList]\n"
8401 "set data(fList) [tkMotifFDialog_MakeSList $w $f2b Files: 2 FList]\n"
8402 "label $f3.lab -text \"Selection:\" -under 0 -anchor w\n"
8403 "entry $f3.ent\n"
8404 "pack $f3.lab -side top -fill x -padx 6 -pady 0\n"
8405 "pack $f3.ent -side top -fill x -padx 4 -pady 4\n"
8406 "set data(sEnt) $f3.ent\n"
8407 "set data(okBtn) [button $bot.ok -text OK -width 6 -under 0 \\\n"
8408 "\011-command [list tkMotifFDialog_OkCmd $w]]\n"
8409 "set data(filterBtn) [button $bot.filter -text Filter -width 6 -under 0 \\\n"
8410 "\011-command [list tkMotifFDialog_FilterCmd $w]]\n"
8411 "set data(cancelBtn) [button $bot.cancel -text Cancel -width 6 -under 0 \\\n"
8412 "\011-command [list tkMotifFDialog_CancelCmd $w]]\n"
8413 "pack $bot.ok $bot.filter $bot.cancel -padx 10 -pady 10 -expand yes \\\n"
8414 "\011-side left\n"
8415 "bind $w <Alt-t> [list focus $data(fEnt)]\n"
8416 "bind $w <Alt-d> [list focus $data(dList)]\n"
8417 "bind $w <Alt-l> [list focus $data(fList)]\n"
8418 "bind $w <Alt-s> [list focus $data(sEnt)]\n"
8419 "bind $w <Alt-o> [list tkButtonInvoke $bot.ok]\n"
8420 "bind $w <Alt-f> [list tkButtonInvoke $bot.filter]\n"
8421 "bind $w <Alt-c> [list tkButtonInvoke $bot.cancel]\n"
8422 "bind $data(fEnt) <Return> [list tkMotifFDialog_ActivateFEnt $w]\n"
8423 "bind $data(sEnt) <Return> [list tkMotifFDialog_ActivateSEnt $w]\n"
8424 "wm protocol $w WM_DELETE_WINDOW [list tkMotifFDialog_CancelCmd $w]\n"
8425 "}\n"
8426 "proc tkMotifFDialog_MakeSList {w f label under cmdPrefix} {\n"
8427 "label $f.lab -text $label -under $under -anchor w\n"
8428 "listbox $f.l -width 12 -height 5 -selectmode browse -exportselection 0\\\n"
8429 "\011-xscrollcommand [list $f.h set]\011-yscrollcommand [list $f.v set]\n"
8430 "scrollbar $f.v -orient vertical -takefocus 0 -command [list $f.l yview]\n"
8431 "scrollbar $f.h -orient horizontal -takefocus 0 -command [list $f.l xview]\n"
8432 "grid $f.lab -row 0 -column 0 -sticky news -rowspan 1 -columnspan 2 \\\n"
8433 "\011-padx 2 -pady 2\n"
8434 "grid $f.l -row 1 -column 0 -rowspan 1 -columnspan 1 -sticky news\n"
8435 "grid $f.v -row 1 -column 1 -rowspan 1 -columnspan 1 -sticky news\n"
8436 "grid $f.h -row 2 -column 0 -rowspan 1 -columnspan 1 -sticky news\n"
8437 "grid rowconfig $f 0 -weight 0 -minsize 0\n"
8438 "grid rowconfig $f 1 -weight 1 -minsize 0\n"
8439 "grid columnconfig $f 0 -weight 1 -minsize 0\n"
8440 "set list $f.l\n"
8441 "bind $list <Up>\011\011[list tkMotifFDialog_Browse$cmdPrefix $w]\n"
8442 "bind $list <Down>\011\011[list tkMotifFDialog_Browse$cmdPrefix $w]\n"
8443 "bind $list <space>\011\011[list tkMotifFDialog_Browse$cmdPrefix $w]\n"
8444 "bind $list <1>\011\011[list tkMotifFDialog_Browse$cmdPrefix $w]\n"
8445 "bind $list <B1-Motion>\011[list tkMotifFDialog_Browse$cmdPrefix $w]\n"
8446 "bind $list <Double-ButtonRelease-1> \\\n"
8447 "\011 [list tkMotifFDialog_Activate$cmdPrefix $w]\n"
8448 "bind $list <Return> \"tkMotifFDialog_Browse$cmdPrefix [list $w]; \\\n"
8449 "\011 tkMotifFDialog_Activate$cmdPrefix [list $w]\"\n"
8450 "bindtags $list [list Listbox $list [winfo toplevel $list] all]\n"
8451 "tkListBoxKeyAccel_Set $list\n"
8452 "return $f.l\n"
8453 "}\n"
8454 "proc tkMotifFDialog_InterpFilter {w} {\n"
8455 "upvar ::tk::dialog::file::[winfo name $w] data\n"
8456 "set text [string trim [$data(fEnt) get]]\n"
8457 "set badTilde 0\n"
8458 "if {[string equal [string index $text 0] ~]} {\n"
8459 "set list [file split $text]\n"
8460 "set tilde [lindex $list 0]\n"
8461 "if {[catch {set tilde [glob $tilde]}]} {\n"
8462 "set badTilde 1\n"
8463 "} else {\n"
8464 "set text [eval file join [concat $tilde [lrange $list 1 end]]]\n"
8465 "}\n"
8466 "}\n"
8467 "set relative 0\n"
8468 "if {[string equal [file pathtype $text] \"relative\"]} {\n"
8469 "set relative 1\n"
8470 "} elseif {$badTilde} {\n"
8471 "set relative 1\011\n"
8472 "}\n"
8473 "if {$relative} {\n"
8474 "tk_messageBox -icon warning -type ok \\\n"
8475 "\011 -message \"\\\"$text\\\" must be an absolute pathname\"\n"
8476 "$data(fEnt) delete 0 end\n"
8477 "$data(fEnt) insert 0 [::tk::dialog::file::JoinFile $data(selectPath) \\\n"
8478 "\011\011$data(filter)]\n"
8479 "return [list $data(selectPath) $data(filter)]\n"
8480 "}\n"
8481 "set resolved [::tk::dialog::file::JoinFile [file dirname $text] [file tail $text]]\n"
8482 "if {[file isdirectory $resolved]} {\n"
8483 "set dir $resolved\n"
8484 "set fil $data(filter)\n"
8485 "} else {\n"
8486 "set dir [file dirname $resolved]\n"
8487 "set fil [file tail $resolved]\n"
8488 "}\n"
8489 "return [list $dir $fil]\n"
8490 "}\n"
8491 "proc tkMotifFDialog_Update {w} {\n"
8492 "upvar ::tk::dialog::file::[winfo name $w] data\n"
8493 "$data(fEnt) delete 0 end\n"
8494 "$data(fEnt) insert 0 [::tk::dialog::file::JoinFile $data(selectPath) $data(filter)]\n"
8495 "$data(sEnt) delete 0 end\n"
8496 "$data(sEnt) insert 0 [::tk::dialog::file::JoinFile $data(selectPath) \\\n"
8497 "\011 $data(selectFile)]\n"
8498 "tkMotifFDialog_LoadFiles $w\n"
8499 "}\n"
8500 "proc tkMotifFDialog_LoadFiles {w} {\n"
8501 "upvar ::tk::dialog::file::[winfo name $w] data\n"
8502 "$data(dList) delete 0 end\n"
8503 "$data(fList) delete 0 end\n"
8504 "set appPWD [pwd]\n"
8505 "if {[catch {cd $data(selectPath)}]} {\n"
8506 "cd $appPWD\n"
8507 "$data(dList) insert end \"..\"\n"
8508 "return\n"
8509 "}\n"
8510 "foreach f [lsort -dictionary [glob -nocomplain .* *]] {\n"
8511 "if {[file isdir ./$f]} {\n"
8512 "$data(dList) insert end $f\n"
8513 "}\n"
8514 "}\n"
8515 "if {[string equal $data(filter) *]} {\n"
8516 "set files [lsort -dictionary [glob -nocomplain .* *]]\n"
8517 "} else {\n"
8518 "set files [lsort -dictionary \\\n"
8519 "\011 [glob -nocomplain $data(filter)]]\n"
8520 "}\n"
8521 "set top 0\n"
8522 "foreach f $files {\n"
8523 "if {![file isdir ./$f]} {\n"
8524 "regsub {^[.]/} $f \"\" f\n"
8525 "$data(fList) insert end $f\n"
8526 "if {[string match .* $f]} {\n"
8527 "incr top\n"
8528 "}\n"
8529 "}\n"
8530 "}\n"
8531 "$data(fList) yview $top\n"
8532 "cd $appPWD\n"
8533 "}\n"
8534 "proc tkMotifFDialog_BrowseDList {w} {\n"
8535 "upvar ::tk::dialog::file::[winfo name $w] data\n"
8536 "focus $data(dList)\n"
8537 "if {[string equal [$data(dList) curselection] \"\"]} {\n"
8538 "return\n"
8539 "}\n"
8540 "set subdir [$data(dList) get [$data(dList) curselection]]\n"
8541 "if {[string equal $subdir \"\"]} {\n"
8542 "return\n"
8543 "}\n"
8544 "$data(fList) selection clear 0 end\n"
8545 "set list [tkMotifFDialog_InterpFilter $w]\n"
8546 "set data(filter) [lindex $list 1]\n"
8547 "switch -- $subdir {\n"
8548 ". {\n"
8549 "set newSpec [::tk::dialog::file::JoinFile $data(selectPath) $data(filter)]\n"
8550 "}\n"
8551 ".. {\n"
8552 "set newSpec [::tk::dialog::file::JoinFile [file dirname $data(selectPath)] \\\n"
8553 "\011\011$data(filter)]\n"
8554 "}\n"
8555 "default {\n"
8556 "set newSpec [::tk::dialog::file::JoinFile [::tk::dialog::file::JoinFile \\\n"
8557 "\011\011 $data(selectPath) $subdir] $data(filter)]\n"
8558 "}\n"
8559 "}\n"
8560 "$data(fEnt) delete 0 end\n"
8561 "$data(fEnt) insert 0 $newSpec\n"
8562 "}\n"
8563 "proc tkMotifFDialog_ActivateDList {w} {\n"
8564 "upvar ::tk::dialog::file::[winfo name $w] data\n"
8565 "if {[string equal [$data(dList) curselection] \"\"]} {\n"
8566 "return\n"
8567 "}\n"
8568 "set subdir [$data(dList) get [$data(dList) curselection]]\n"
8569 "if {[string equal $subdir \"\"]} {\n"
8570 "return\n"
8571 "}\n"
8572 "$data(fList) selection clear 0 end\n"
8573 "switch -- $subdir {\n"
8574 ". {\n"
8575 "set newDir $data(selectPath)\n"
8576 "}\n"
8577 ".. {\n"
8578 "set newDir [file dirname $data(selectPath)]\n"
8579 "}\n"
8580 "default {\n"
8581 "set newDir [::tk::dialog::file::JoinFile $data(selectPath) $subdir]\n"
8582 "}\n"
8583 "}\n"
8584 "set data(selectPath) $newDir\n"
8585 "tkMotifFDialog_Update $w\n"
8586 "if {[string compare $subdir ..]} {\n"
8587 "$data(dList) selection set 0\n"
8588 "$data(dList) activate 0\n"
8589 "} else {\n"
8590 "$data(dList) selection set 1\n"
8591 "$data(dList) activate 1\n"
8592 "}\n"
8593 "}\n"
8594 "proc tkMotifFDialog_BrowseFList {w} {\n"
8595 "upvar ::tk::dialog::file::[winfo name $w] data\n"
8596 "focus $data(fList)\n"
8597 "if {[string equal [$data(fList) curselection] \"\"]} {\n"
8598 "return\n"
8599 "}\n"
8600 "set data(selectFile) [$data(fList) get [$data(fList) curselection]]\n"
8601 "if {[string equal $data(selectFile) \"\"]} {\n"
8602 "return\n"
8603 "}\n"
8604 "$data(dList) selection clear 0 end\n"
8605 "$data(fEnt) delete 0 end\n"
8606 "$data(fEnt) insert 0 [::tk::dialog::file::JoinFile $data(selectPath) $data(filter)]\n"
8607 "$data(fEnt) xview end\n"
8608 "$data(sEnt) delete 0 end\n"
8609 "$data(sEnt) insert 0 [::tk::dialog::file::JoinFile $data(selectPath) \\\n"
8610 "\011 $data(selectFile)]\n"
8611 "$data(sEnt) xview end\n"
8612 "}\n"
8613 "proc tkMotifFDialog_ActivateFList {w} {\n"
8614 "upvar ::tk::dialog::file::[winfo name $w] data\n"
8615 "if {[string equal [$data(fList) curselection] \"\"]} {\n"
8616 "return\n"
8617 "}\n"
8618 "set data(selectFile) [$data(fList) get [$data(fList) curselection]]\n"
8619 "if {[string equal $data(selectFile) \"\"]} {\n"
8620 "return\n"
8621 "} else {\n"
8622 "tkMotifFDialog_ActivateSEnt $w\n"
8623 "}\n"
8624 "}\n"
8625 "proc tkMotifFDialog_ActivateFEnt {w} {\n"
8626 "upvar ::tk::dialog::file::[winfo name $w] data\n"
8627 "set list [tkMotifFDialog_InterpFilter $w]\n"
8628 "set data(selectPath) [lindex $list 0]\n"
8629 "set data(filter) [lindex $list 1]\n"
8630 "tkMotifFDialog_Update $w\n"
8631 "}\n"
8632 "proc tkMotifFDialog_ActivateSEnt {w} {\n"
8633 "global tkPriv\n"
8634 "upvar ::tk::dialog::file::[winfo name $w] data\n"
8635 "set selectFilePath [string trim [$data(sEnt) get]]\n"
8636 "set selectFile [file tail $selectFilePath]\n"
8637 "set selectPath [file dirname $selectFilePath]\n"
8638 "if {[string equal $selectFilePath \"\"]} {\n"
8639 "tkMotifFDialog_FilterCmd $w\n"
8640 "return\n"
8641 "}\n"
8642 "if {[file isdirectory $selectFilePath]} {\n"
8643 "set data(selectPath) [glob $selectFilePath]\n"
8644 "set data(selectFile) \"\"\n"
8645 "tkMotifFDialog_Update $w\n"
8646 "return\n"
8647 "}\n"
8648 "if {[string compare [file pathtype $selectFilePath] \"absolute\"]} {\n"
8649 "tk_messageBox -icon warning -type ok \\\n"
8650 "\011 -message \"\\\"$selectFilePath\\\" must be an absolute pathname\"\n"
8651 "return\n"
8652 "}\n"
8653 "if {![file exists $selectPath]} {\n"
8654 "tk_messageBox -icon warning -type ok \\\n"
8655 "\011 -message \"Directory \\\"$selectPath\\\" does not exist.\"\n"
8656 "return\n"
8657 "}\n"
8658 "if {![file exists $selectFilePath]} {\n"
8659 "if {[string equal $data(type) open]} {\n"
8660 "tk_messageBox -icon warning -type ok \\\n"
8661 "\011\011-message \"File \\\"$selectFilePath\\\" does not exist.\"\n"
8662 "return\n"
8663 "}\n"
8664 "} else {\n"
8665 "if {[string equal $data(type) save]} {\n"
8666 "set message [format %s%s \\\n"
8667 "\011\011\"File \\\"$selectFilePath\\\" already exists.\\n\\n\" \\\n"
8668 "\011\011\"Replace existing file?\"]\n"
8669 "set answer [tk_messageBox -icon warning -type yesno \\\n"
8670 "\011\011-message $message]\n"
8671 "if {[string equal $answer \"no\"]} {\n"
8672 "return\n"
8673 "}\n"
8674 "}\n"
8675 "}\n"
8676 "set tkPriv(selectFilePath) $selectFilePath\n"
8677 "set tkPriv(selectFile) $selectFile\n"
8678 "set tkPriv(selectPath) $selectPath\n"
8679 "}\n"
8680 "proc tkMotifFDialog_OkCmd {w} {\n"
8681 "upvar ::tk::dialog::file::[winfo name $w] data\n"
8682 "tkMotifFDialog_ActivateSEnt $w\n"
8683 "}\n"
8684 "proc tkMotifFDialog_FilterCmd {w} {\n"
8685 "upvar ::tk::dialog::file::[winfo name $w] data\n"
8686 "tkMotifFDialog_ActivateFEnt $w\n"
8687 "}\n"
8688 "proc tkMotifFDialog_CancelCmd {w} {\n"
8689 "global tkPriv\n"
8690 "set tkPriv(selectFilePath) \"\"\n"
8691 "set tkPriv(selectFile) \"\"\n"
8692 "set tkPriv(selectPath) \"\"\n"
8693 "}\n"
8694 "proc tkListBoxKeyAccel_Set {w} {\n"
8695 "bind Listbox <Any-KeyPress> \"\"\n"
8696 "bind $w <Destroy> [list tkListBoxKeyAccel_Unset $w]\n"
8697 "bind $w <Any-KeyPress> [list tkListBoxKeyAccel_Key $w %A]\n"
8698 "}\n"
8699 "proc tkListBoxKeyAccel_Unset {w} {\n"
8700 "global tkPriv\n"
8701 "catch {after cancel $tkPriv(lbAccel,$w,afterId)}\n"
8702 "catch {unset tkPriv(lbAccel,$w)}\n"
8703 "catch {unset tkPriv(lbAccel,$w,afterId)}\n"
8704 "}\n"
8705 "proc tkListBoxKeyAccel_Key {w key} {\n"
8706 "global tkPriv\n"
8707 "append tkPriv(lbAccel,$w) $key\n"
8708 "tkListBoxKeyAccel_Goto $w $tkPriv(lbAccel,$w)\n"
8709 "catch {\n"
8710 "after cancel $tkPriv(lbAccel,$w,afterId)\n"
8711 "}\n"
8712 "set tkPriv(lbAccel,$w,afterId) [after 500 \\\n"
8713 "\011 [list tkListBoxKeyAccel_Reset $w]]\n"
8714 "}\n"
8715 "proc tkListBoxKeyAccel_Goto {w string} {\n"
8716 "global tkPriv\n"
8717 "set string [string tolower $string]\n"
8718 "set end [$w index end]\n"
8719 "set theIndex -1\n"
8720 "for {set i 0} {$i < $end} {incr i} {\n"
8721 "set item [string tolower [$w get $i]]\n"
8722 "if {[string compare $string $item] >= 0} {\n"
8723 "set theIndex $i\n"
8724 "}\n"
8725 "if {[string compare $string $item] <= 0} {\n"
8726 "set theIndex $i\n"
8727 "break\n"
8728 "}\n"
8729 "}\n"
8730 "if {$theIndex >= 0} {\n"
8731 "$w selection clear 0 end\n"
8732 "$w selection set $theIndex $theIndex\n"
8733 "$w activate $theIndex\n"
8734 "$w see $theIndex\n"
8735 "}\n"
8736 "}\n"
8737 "proc tkListBoxKeyAccel_Reset {w} {\n"
8738 "global tkPriv\n"
8739 "catch {unset tkPriv(lbAccel,$w)}\n"
8740 "}\n"
8741 ;
8742 struct EtFile {
8743 char *zName;
8744 char *zData;
8745 int nData;
8746 int shrouded;
8747 struct EtFile *pNext;
8748 };
8749 static struct EtFile Et_FileSet[] = {
8750 { "C:/PROGRAM FILES/TCL/lib/tcl8.3/auto.tcl", Et_zFile0, sizeof(Et_zFile0)-1, 0, 0 },
8751 { "C:/PROGRAM FILES/TCL/lib/tcl8.3/history.tcl", Et_zFile1, sizeof(Et_zFile1)-1, 0, 0 },
8752 { "C:/PROGRAM FILES/TCL/lib/tcl8.3/init.tcl", Et_zFile2, sizeof(Et_zFile2)-1, 0, 0 },
8753 { "C:/PROGRAM FILES/TCL/lib/tcl8.3/package.tcl", Et_zFile3, sizeof(Et_zFile3)-1, 0, 0 },
8754 { "C:/PROGRAM FILES/TCL/lib/tcl8.3/parray.tcl", Et_zFile4, sizeof(Et_zFile4)-1, 0, 0 },
8755 { "C:/PROGRAM FILES/TCL/lib/tcl8.3/safe.tcl", Et_zFile5, sizeof(Et_zFile5)-1, 0, 0 },
8756 { "C:/PROGRAM FILES/TCL/lib/tcl8.3/tclIndex", Et_zFile6, sizeof(Et_zFile6)-1, 0, 0 },
8757 { "C:/PROGRAM FILES/TCL/lib/tcl8.3/word.tcl", Et_zFile7, sizeof(Et_zFile7)-1, 0, 0 },
8758 { "C:/PROGRAM FILES/TCL/lib/tk8.3/bgerror.tcl", Et_zFile8, sizeof(Et_zFile8)-1, 0, 0 },
8759 { "C:/PROGRAM FILES/TCL/lib/tk8.3/button.tcl", Et_zFile9, sizeof(Et_zFile9)-1, 0, 0 },
8760 { "C:/PROGRAM FILES/TCL/lib/tk8.3/clrpick.tcl", Et_zFile10, sizeof(Et_zFile10)-1, 0, 0 },
8761 { "C:/PROGRAM FILES/TCL/lib/tk8.3/comdlg.tcl", Et_zFile11, sizeof(Et_zFile11)-1, 0, 0 },
8762 { "C:/PROGRAM FILES/TCL/lib/tk8.3/console.tcl", Et_zFile12, sizeof(Et_zFile12)-1, 0, 0 },
8763 { "C:/PROGRAM FILES/TCL/lib/tk8.3/dialog.tcl", Et_zFile13, sizeof(Et_zFile13)-1, 0, 0 },
8764 { "C:/PROGRAM FILES/TCL/lib/tk8.3/entry.tcl", Et_zFile14, sizeof(Et_zFile14)-1, 0, 0 },
8765 { "C:/PROGRAM FILES/TCL/lib/tk8.3/focus.tcl", Et_zFile15, sizeof(Et_zFile15)-1, 0, 0 },
8766 { "C:/PROGRAM FILES/TCL/lib/tk8.3/listbox.tcl", Et_zFile16, sizeof(Et_zFile16)-1, 0, 0 },
8767 { "C:/PROGRAM FILES/TCL/lib/tk8.3/menu.tcl", Et_zFile17, sizeof(Et_zFile17)-1, 0, 0 },
8768 { "C:/PROGRAM FILES/TCL/lib/tk8.3/msgbox.tcl", Et_zFile18, sizeof(Et_zFile18)-1, 0, 0 },
8769 { "C:/PROGRAM FILES/TCL/lib/tk8.3/obsolete.tcl", Et_zFile19, sizeof(Et_zFile19)-1, 0, 0 },
8770 { "C:/PROGRAM FILES/TCL/lib/tk8.3/optMenu.tcl", Et_zFile20, sizeof(Et_zFile20)-1, 0, 0 },
8771 { "C:/PROGRAM FILES/TCL/lib/tk8.3/palette.tcl", Et_zFile21, sizeof(Et_zFile21)-1, 0, 0 },
8772 { "C:/PROGRAM FILES/TCL/lib/tk8.3/safetk.tcl", Et_zFile22, sizeof(Et_zFile22)-1, 0, 0 },
8773 { "C:/PROGRAM FILES/TCL/lib/tk8.3/scale.tcl", Et_zFile23, sizeof(Et_zFile23)-1, 0, 0 },
8774 { "C:/PROGRAM FILES/TCL/lib/tk8.3/scrlbar.tcl", Et_zFile24, sizeof(Et_zFile24)-1, 0, 0 },
8775 { "C:/PROGRAM FILES/TCL/lib/tk8.3/tclIndex", Et_zFile25, sizeof(Et_zFile25)-1, 0, 0 },
8776 { "C:/PROGRAM FILES/TCL/lib/tk8.3/tearoff.tcl", Et_zFile26, sizeof(Et_zFile26)-1, 0, 0 },
8777 { "C:/PROGRAM FILES/TCL/lib/tk8.3/text.tcl", Et_zFile27, sizeof(Et_zFile27)-1, 0, 0 },
8778 { "C:/PROGRAM FILES/TCL/lib/tk8.3/tk.tcl", Et_zFile28, sizeof(Et_zFile28)-1, 0, 0 },
8779 { "C:/PROGRAM FILES/TCL/lib/tk8.3/tkfbox.tcl", Et_zFile29, sizeof(Et_zFile29)-1, 0, 0 },
8780 { "C:/PROGRAM FILES/TCL/lib/tk8.3/xmfbox.tcl", Et_zFile30, sizeof(Et_zFile30)-1, 0, 0 },
8781 {0, 0}};
8782 static struct EtFile *Et_FileHashTable[71];
8783 /* The following copyright notice applies to code generated by
8784 ** "mktclapp". The "mktclapp" program itself is covered by the
8785 ** GNU Public License.
8786 **
8787 ** Copyright (c) 1998 D. Richard Hipp
8788 **
8789 ** The author hereby grants permission to use, copy, modify, distribute,
8790 ** and license this software and its documentation for any purpose, provided
8791 ** that existing copyright notices are retained in all copies and that this
8792 ** notice is included verbatim in any distributions. No written agreement,
8793 ** license, or royalty fee is required for any of the authorized uses.
8794 ** Modifications to this software may be copyrighted by their authors
8795 ** and need not follow the licensing terms described here, provided that
8796 ** the new terms are clearly indicated on the first page of each file where
8797 ** they apply.
8798 **
8799 ** In no event shall the author or the distributors be liable to any party
8800 ** for direct, indirect, special, incidental, or consequential damages
8801 ** arising out of the use of this software, its documentation, or any
8802 ** derivatives thereof, even if the author has been advised of the
8803 ** possibility of such damage. The author and distributors specifically
8804 ** disclaim any warranties, including but not limited to the implied
8805 ** warranties of merchantability, fitness for a particular purpose, and
8806 ** non-infringment. This software is provided at no fee on an
8807 ** "as is" basis. The author and/or distritutors have no obligation
8808 ** to provide maintenance, support, updates, enhancements and/or
8809 ** modifications.
8810 **
8811 ** GOVERNMENT USE: If you are acquiring this software on behalf of the
8812 ** U.S. government, the Government shall have only "Restricted Rights"
8813 ** in the software and related documentation as defined in the Federal
8814 ** Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you
8815 ** are acquiring the software on behalf of the Department of Defense, the
8816 ** software shall be classified as "Commercial Computer Software" and the
8817 ** Government shall have only "Restricted Rights" as defined in Clause
8818 ** 252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the
8819 ** author grants the U.S. Government and others acting in its behalf
8820 ** permission to use and distribute the software in accordance with the
8821 ** terms specified in this license.
8822 */
8823 #include <ctype.h>
8824 #include <string.h>
8825 #include <stdarg.h>
8826 #include <stdio.h>
8827 #include <stdlib.h>
8828 #include <sys/types.h>
8829 #include <sys/stat.h>
8830 #include <fcntl.h>
8831
8832 /* Include either the Tcl or the Tk header file. Use the "Internal"
8833 ** version of the header file if and only if we are generating an
8834 ** extension that is linking against the Stub library.
8835 ** Many installations do not have the internal header files
8836 ** available, so using the internal headers only when absolutely
8837 ** necessary will help to reduce compilation problems.
8838 */
8839 #if ET_EXTENSION && defined(TCL_USE_STUBS)
8840 # if ET_ENABLE_TK
8841 # include <tkInt.h>
8842 # else
8843 # include <tclInt.h>
8844 # endif
8845 #else
8846 # if ET_ENABLE_TK
8847 # include <tk.h>
8848 # else
8849 # include <tcl.h>
8850 # endif
8851 #endif
8852
8853 /*
8854 ** ET_WIN32 is true if we are running Tk under windows. The
8855 ** <tcl.h> module will define __WIN32__ for us if we are compiling
8856 ** for windows.
8857 */
8858 #if defined(__WIN32__) && ET_ENABLE_TK
8859 # define ET_WIN32 1
8860 # include <windows.h>
8861 #else
8862 # define ET_WIN32 0
8863 #endif
8864
8865 /*
8866 ** Always disable ET_AUTO_FORK under windows. Windows doesn't
8867 ** fork well.
8868 */
8869 #if defined(__WIN32__)
8870 # undef ET_AUTO_FORK
8871 # define ET_AUTO_FORK 0
8872 #endif
8873
8874 /*
8875 ** Omit <unistd.h> under windows. But we need it for Unix.
8876 */
8877 #if !defined(__WIN32__)
8878 # include <unistd.h>
8879 #endif
8880
8881 /*
8882 ** The Tcl*InsertProc functions allow the system calls "stat",
8883 ** "access" and "open" to be overloaded. This in turns allows us
8884 ** to substituted compiled-in strings for files in the filesystem.
8885 ** But the Tcl*InsertProc functions are only available in Tcl8.0.3
8886 ** and later.
8887 **
8888 ** Define the ET_HAVE_INSERTPROC macro if and only if we are dealing
8889 ** with Tcl8.0.3 or later.
8890 */
8891 #if TCL_MAJOR_VERSION==8 && (TCL_MINOR_VERSION>0 || TCL_RELEASE_SERIAL>=3)
8892 # define ET_HAVE_INSERTPROC
8893 #endif
8894
8895 /*
8896 ** If we are using the Tcl*InsertProc() functions, we should provide
8897 ** prototypes for them. But the prototypes are in the tclInt.h include
8898 ** file, which we don't want to require the user to have on hand. So
8899 ** we provide our own prototypes here.
8900 **
8901 ** Note that if TCL_USE_STUBS is defined, then the tclInt.h is required
8902 ** anyway, so these prototypes are not included if TCL_USE_STUBS is
8903 ** defined.
8904 */
8905 #if defined(ET_HAVE_INSERTPROC) && !defined(TCL_USE_STUBS)
8906 #ifdef __cplusplus
8907 extern "C" int TclStatInsertProc(int (*)(char*, struct stat *));
8908 extern "C" int TclAccessInsertProc(int (*)(char*, int));
8909 extern "C" int TclOpenFileChannelInsertProc(Tcl_Channel (*)(Tcl_Interp*,char*,
8910 char*,int));
8911 #else
8912 extern int TclStatInsertProc(int (*)(char*, struct stat *));
8913 extern int TclAccessInsertProc(int (*)(char*, int));
8914 extern int TclOpenFileChannelInsertProc(Tcl_Channel (*)(Tcl_Interp*,char*,
8915 char*,int));
8916 #endif
8917 #endif
8918
8919
8920 /*
8921 ** Don't allow Win32 applications to read from stdin. Nor
8922 ** programs that automatically go into the background. Force
8923 ** the use of a console in these cases.
8924 */
8925 #if (ET_WIN32 || ET_AUTO_FORK) && ET_READ_STDIN
8926 # undef ET_READ_STDIN
8927 # undef ET_CONSOLE
8928 # define ET_READ_STDIN 0
8929 # define ET_CONSOLE 1
8930 #endif
8931
8932 /*
8933 ** The console won't work without Tk.
8934 */
8935 #if ET_ENABLE_TK==0 && ET_CONSOLE
8936 # undef ET_CONSOLE
8937 # define ET_CONSOLE 0
8938 # undef ET_READ_STDIN
8939 # define ET_READ_STDIN 1
8940 #endif
8941
8942 /*
8943 ** We MUST start using Tcl_GetStringResult() in Tcl8.3
8944 ** But these functions didn't exists in Tcl 7.6. So make
8945 ** them macros.
8946 */
8947 #if TCL_MAJOR_VERSION<8
8948 # define Tcl_GetStringResult(I) ((I)->result)
8949 #endif
8950
8951 /*
8952 ** Set ET_HAVE_OBJ to true if we are able to link against the
8953 ** new Tcl_Obj interface. This is only the case for Tcl version
8954 ** 8.0 and later.
8955 */
8956 #if ET_ENABLE_OBJ || TCL_MAJOR_VERSION>=8
8957 # define ET_HAVE_OBJ 1
8958 #else
8959 # define ET_HAVE_OBJ 0
8960 #endif
8961
8962 /*
8963 ** The Tcl_GetByteArrayFromObj() only appears in Tcl version 8.1
8964 ** and later. Substitute Tcl_GetStringFromObj() in Tcl version 8.0.X
8965 */
8966 #if ET_HAVE_OBJ && TCL_MINOR_VERSION==0
8967 # define Tcl_GetByteArrayFromObj Tcl_GetStringFromObj
8968 #endif
8969
8970 /*
8971 ** Tcl code to implement the console.
8972 **
8973 ** This code is written and tested separately, then run through
8974 ** "mktclapp -stringify" and then pasted in here.
8975 */
8976 #if ET_ENABLE_TK && !ET_EXTENSION
8977 static char zEtConsole[] =
8978 "proc console:create {w prompt title} {\n"
8979 "upvar #0 $w.t v\n"
8980 "if {[winfo exists $w]} {destroy $w}\n"
8981 "if {[info exists v]} {unset v}\n"
8982 "toplevel $w\n"
8983 "wm title $w $title\n"
8984 "wm iconname $w $title\n"
8985 "frame $w.mb -bd 2 -relief raised\n"
8986 "pack $w.mb -side top -fill x\n"
8987 "menubutton $w.mb.file -text File -menu $w.mb.file.m\n"
8988 "menubutton $w.mb.edit -text Edit -menu $w.mb.edit.m\n"
8989 "pack $w.mb.file $w.mb.edit -side left -padx 8 -pady 1\n"
8990 "set m [menu $w.mb.file.m]\n"
8991 "$m add command -label {Source...} -command \"console:SourceFile $w.t\"\n"
8992 "$m add command -label {Save As...} -command \"console:SaveFile $w.t\"\n"
8993 "$m add separator\n"
8994 "$m add command -label {Close} -command \"destroy $w\"\n"
8995 "$m add command -label {Exit} -command exit\n"
8996 "set m [menu $w.mb.edit.m]\n"
8997 "$m add command -label Cut -command \"console:Cut $w.t\"\n"
8998 "$m add command -label Copy -command \"console:Copy $w.t\"\n"
8999 "$m add command -label Paste -command \"console:Paste $w.t\"\n"
9000 "$m add command -label {Clear Screen} -command \"console:Clear $w.t\"\n"
9001 "catch {$m config -postcommand \"console:EnableEditMenu $w\"}\n"
9002 "scrollbar $w.sb -orient vertical -command \"$w.t yview\"\n"
9003 "pack $w.sb -side right -fill y\n"
9004 "text $w.t -font fixed -yscrollcommand \"$w.sb set\"\n"
9005 "pack $w.t -side right -fill both -expand 1\n"
9006 "bindtags $w.t Console\n"
9007 "set v(text) $w.t\n"
9008 "set v(history) 0\n"
9009 "set v(historycnt) 0\n"
9010 "set v(current) -1\n"
9011 "set v(prompt) $prompt\n"
9012 "set v(prior) {}\n"
9013 "set v(plength) [string length $v(prompt)]\n"
9014 "set v(x) 0\n"
9015 "set v(y) 0\n"
9016 "$w.t mark set insert end\n"
9017 "$w.t tag config ok -foreground blue\n"
9018 "$w.t tag config err -foreground red\n"
9019 "$w.t insert end $v(prompt)\n"
9020 "$w.t mark set out 1.0\n"
9021 "catch {rename puts console:oldputs$w}\n"
9022 "proc puts args [format {\n"
9023 "if {![winfo exists %s]} {\n"
9024 "rename puts {}\n"
9025 "rename console:oldputs%s puts\n"
9026 "return [uplevel #0 puts $args]\n"
9027 "}\n"
9028 "switch -glob -- \"[llength $args] $args\" {\n"
9029 "{1 *} {\n"
9030 "set msg [lindex $args 0]\\n\n"
9031 "set tag ok\n"
9032 "}\n"
9033 "{2 stdout *} {\n"
9034 "set msg [lindex $args 1]\\n\n"
9035 "set tag ok\n"
9036 "}\n"
9037 "{2 stderr *} {\n"
9038 "set msg [lindex $args 1]\\n\n"
9039 "set tag err\n"
9040 "}\n"
9041 "{2 -nonewline *} {\n"
9042 "set msg [lindex $args 1]\n"
9043 "set tag ok\n"
9044 "}\n"
9045 "{3 -nonewline stdout *} {\n"
9046 "set msg [lindex $args 2]\n"
9047 "set tag ok\n"
9048 "}\n"
9049 "{3 -nonewline stderr *} {\n"
9050 "set msg [lindex $args 2]\n"
9051 "set tag err\n"
9052 "}\n"
9053 "default {\n"
9054 "uplevel #0 console:oldputs%s $args\n"
9055 "return\n"
9056 "}\n"
9057 "}\n"
9058 "console:Puts %s $msg $tag\n"
9059 "} $w $w $w $w.t]\n"
9060 "after idle \"focus $w.t\"\n"
9061 "}\n"
9062 "bind Console <1> {console:Button1 %W %x %y}\n"
9063 "bind Console <B1-Motion> {console:B1Motion %W %x %y}\n"
9064 "bind Console <B1-Leave> {console:B1Leave %W %x %y}\n"
9065 "bind Console <B1-Enter> {console:cancelMotor %W}\n"
9066 "bind Console <ButtonRelease-1> {console:cancelMotor %W}\n"
9067 "bind Console <KeyPress> {console:Insert %W %A}\n"
9068 "bind Console <Left> {console:Left %W}\n"
9069 "bind Console <Control-b> {console:Left %W}\n"
9070 "bind Console <Right> {console:Right %W}\n"
9071 "bind Console <Control-f> {console:Right %W}\n"
9072 "bind Console <BackSpace> {console:Backspace %W}\n"
9073 "bind Console <Control-h> {console:Backspace %W}\n"
9074 "bind Console <Delete> {console:Delete %W}\n"
9075 "bind Console <Control-d> {console:Delete %W}\n"
9076 "bind Console <Home> {console:Home %W}\n"
9077 "bind Console <Control-a> {console:Home %W}\n"
9078 "bind Console <End> {console:End %W}\n"
9079 "bind Console <Control-e> {console:End %W}\n"
9080 "bind Console <Return> {console:Enter %W}\n"
9081 "bind Console <KP_Enter> {console:Enter %W}\n"
9082 "bind Console <Up> {console:Prior %W}\n"
9083 "bind Console <Control-p> {console:Prior %W}\n"
9084 "bind Console <Down> {console:Next %W}\n"
9085 "bind Console <Control-n> {console:Next %W}\n"
9086 "bind Console <Control-k> {console:EraseEOL %W}\n"
9087 "bind Console <<Cut>> {console:Cut %W}\n"
9088 "bind Console <<Copy>> {console:Copy %W}\n"
9089 "bind Console <<Paste>> {console:Paste %W}\n"
9090 "bind Console <<Clear>> {console:Clear %W}\n"
9091 "proc console:Puts {w t tag} {\n"
9092 "set nc [string length $t]\n"
9093 "set endc [string index $t [expr $nc-1]]\n"
9094 "if {$endc==\"\\n\"} {\n"
9095 "if {[$w index out]<[$w index {insert linestart}]} {\n"
9096 "$w insert out [string range $t 0 [expr $nc-2]] $tag\n"
9097 "$w mark set out {out linestart +1 lines}\n"
9098 "} else {\n"
9099 "$w insert out $t $tag\n"
9100 "}\n"
9101 "} else {\n"
9102 "if {[$w index out]<[$w index {insert linestart}]} {\n"
9103 "$w insert out $t $tag\n"
9104 "} else {\n"
9105 "$w insert out $t\\n $tag\n"
9106 "$w mark set out {out -1 char}\n"
9107 "}\n"
9108 "}\n"
9109 "$w yview insert\n"
9110 "}\n"
9111 "proc console:Insert {w a} {\n"
9112 "$w insert insert $a\n"
9113 "$w yview insert\n"
9114 "}\n"
9115 "proc console:Left {w} {\n"
9116 "upvar #0 $w v\n"
9117 "scan [$w index insert] %d.%d row col\n"
9118 "if {$col>$v(plength)} {\n"
9119 "$w mark set insert \"insert -1c\"\n"
9120 "}\n"
9121 "}\n"
9122 "proc console:Backspace {w} {\n"
9123 "upvar #0 $w v\n"
9124 "scan [$w index insert] %d.%d row col\n"
9125 "if {$col>$v(plength)} {\n"
9126 "$w delete {insert -1c}\n"
9127 "}\n"
9128 "}\n"
9129 "proc console:EraseEOL {w} {\n"
9130 "upvar #0 $w v\n"
9131 "scan [$w index insert] %d.%d row col\n"
9132 "if {$col>=$v(plength)} {\n"
9133 "$w delete insert {insert lineend}\n"
9134 "}\n"
9135 "}\n"
9136 "proc console:Right {w} {\n"
9137 "$w mark set insert \"insert +1c\"\n"
9138 "}\n"
9139 "proc console:Delete w {\n"
9140 "$w delete insert\n"
9141 "}\n"
9142 "proc console:Home w {\n"
9143 "upvar #0 $w v\n"
9144 "scan [$w index insert] %d.%d row col\n"
9145 "$w mark set insert $row.$v(plength)\n"
9146 "}\n"
9147 "proc console:End w {\n"
9148 "$w mark set insert {insert lineend}\n"
9149 "}\n"
9150 "proc console:Enter w {\n"
9151 "upvar #0 $w v\n"
9152 "scan [$w index insert] %d.%d row col\n"
9153 "set start $row.$v(plength)\n"
9154 "set line [$w get $start \"$start lineend\"]\n"
9155 "if {$v(historycnt)>0} {\n"
9156 "set last [lindex $v(history) [expr $v(historycnt)-1]]\n"
9157 "if {[string compare $last $line]} {\n"
9158 "lappend v(history) $line\n"
9159 "incr v(historycnt)\n"
9160 "}\n"
9161 "} else {\n"
9162 "set v(history) [list $line]\n"
9163 "set v(historycnt) 1\n"
9164 "}\n"
9165 "set v(current) $v(historycnt)\n"
9166 "$w insert end \\n\n"
9167 "$w mark set out end\n"
9168 "if {$v(prior)==\"\"} {\n"
9169 "set cmd $line\n"
9170 "} else {\n"
9171 "set cmd $v(prior)\\n$line\n"
9172 "}\n"
9173 "if {[info complete $cmd]} {\n"
9174 "set rc [catch {uplevel #0 $cmd} res]\n"
9175 "if {![winfo exists $w]} return\n"
9176 "if {$rc} {\n"
9177 "$w insert end $res\\n err\n"
9178 "} elseif {[string length $res]>0} {\n"
9179 "$w insert end $res\\n ok\n"
9180 "}\n"
9181 "set v(prior) {}\n"
9182 "$w insert end $v(prompt)\n"
9183 "} else {\n"
9184 "set v(prior) $cmd\n"
9185 "regsub -all {[^ ]} $v(prompt) . x\n"
9186 "$w insert end $x\n"
9187 "}\n"
9188 "$w mark set insert end\n"
9189 "$w mark set out {insert linestart}\n"
9190 "$w yview insert\n"
9191 "}\n"
9192 "proc console:Prior w {\n"
9193 "upvar #0 $w v\n"
9194 "if {$v(current)<=0} return\n"
9195 "incr v(current) -1\n"
9196 "set line [lindex $v(history) $v(current)]\n"
9197 "console:SetLine $w $line\n"
9198 "}\n"
9199 "proc console:Next w {\n"
9200 "upvar #0 $w v\n"
9201 "if {$v(current)>=$v(historycnt)} return\n"
9202 "incr v(current) 1\n"
9203 "set line [lindex $v(history) $v(current)]\n"
9204 "console:SetLine $w $line\n"
9205 "}\n"
9206 "proc console:SetLine {w line} {\n"
9207 "upvar #0 $w v\n"
9208 "scan [$w index insert] %d.%d row col\n"
9209 "set start $row.$v(plength)\n"
9210 "$w delete $start end\n"
9211 "$w insert end $line\n"
9212 "$w mark set insert end\n"
9213 "$w yview insert\n"
9214 "}\n"
9215 "proc console:Button1 {w x y} {\n"
9216 "global tkPriv\n"
9217 "upvar #0 $w v\n"
9218 "set v(mouseMoved) 0\n"
9219 "set v(pressX) $x\n"
9220 "set p [console:nearestBoundry $w $x $y]\n"
9221 "scan [$w index insert] %d.%d ix iy\n"
9222 "scan $p %d.%d px py\n"
9223 "if {$px==$ix} {\n"
9224 "$w mark set insert $p\n"
9225 "}\n"
9226 "$w mark set anchor $p\n"
9227 "focus $w\n"
9228 "}\n"
9229 "proc console:nearestBoundry {w x y} {\n"
9230 "set p [$w index @$x,$y]\n"
9231 "set bb [$w bbox $p]\n"
9232 "if {![string compare $bb \"\"]} {return $p}\n"
9233 "if {($x-[lindex $bb 0])<([lindex $bb 2]/2)} {return $p}\n"
9234 "$w index \"$p + 1 char\"\n"
9235 "}\n"
9236 "proc console:SelectTo {w x y} {\n"
9237 "upvar #0 $w v\n"
9238 "set cur [console:nearestBoundry $w $x $y]\n"
9239 "if {[catch {$w index anchor}]} {\n"
9240 "$w mark set anchor $cur\n"
9241 "}\n"
9242 "set anchor [$w index anchor]\n"
9243 "if {[$w compare $cur != $anchor] || (abs($v(pressX) - $x) >= 3)} {\n"
9244 "if {$v(mouseMoved)==0} {\n"
9245 "$w tag remove sel 0.0 end\n"
9246 "}\n"
9247 "set v(mouseMoved) 1\n"
9248 "}\n"
9249 "if {[$w compare $cur < anchor]} {\n"
9250 "set first $cur\n"
9251 "set last anchor\n"
9252 "} else {\n"
9253 "set first anchor\n"
9254 "set last $cur\n"
9255 "}\n"
9256 "if {$v(mouseMoved)} {\n"
9257 "$w tag remove sel 0.0 $first\n"
9258 "$w tag add sel $first $last\n"
9259 "$w tag remove sel $last end\n"
9260 "update idletasks\n"
9261 "}\n"
9262 "}\n"
9263 "proc console:B1Motion {w x y} {\n"
9264 "upvar #0 $w v\n"
9265 "set v(y) $y\n"
9266 "set v(x) $x\n"
9267 "console:SelectTo $w $x $y\n"
9268 "}\n"
9269 "proc console:B1Leave {w x y} {\n"
9270 "upvar #0 $w v\n"
9271 "set v(y) $y\n"
9272 "set v(x) $x\n"
9273 "console:motor $w\n"
9274 "}\n"
9275 "proc console:motor w {\n"
9276 "upvar #0 $w v\n"
9277 "if {![winfo exists $w]} return\n"
9278 "if {$v(y)>=[winfo height $w]} {\n"
9279 "$w yview scroll 1 units\n"
9280 "} elseif {$v(y)<0} {\n"
9281 "$w yview scroll -1 units\n"
9282 "} else {\n"
9283 "return\n"
9284 "}\n"
9285 "console:SelectTo $w $v(x) $v(y)\n"
9286 "set v(timer) [after 50 console:motor $w]\n"
9287 "}\n"
9288 "proc console:cancelMotor w {\n"
9289 "upvar #0 $w v\n"
9290 "catch {after cancel $v(timer)}\n"
9291 "catch {unset v(timer)}\n"
9292 "}\n"
9293 "proc console:Copy w {\n"
9294 "if {![catch {set text [$w get sel.first sel.last]}]} {\n"
9295 "clipboard clear -displayof $w\n"
9296 "clipboard append -displayof $w $text\n"
9297 "}\n"
9298 "}\n"
9299 "proc console:canCut w {\n"
9300 "set r [catch {\n"
9301 "scan [$w index sel.first] %d.%d s1x s1y\n"
9302 "scan [$w index sel.last] %d.%d s2x s2y\n"
9303 "scan [$w index insert] %d.%d ix iy\n"
9304 "}]\n"
9305 "if {$r==1} {return 0}\n"
9306 "if {$s1x==$ix && $s2x==$ix} {return 1}\n"
9307 "return 2\n"
9308 "}\n"
9309 "proc console:Cut w {\n"
9310 "if {[console:canCut $w]==1} {\n"
9311 "console:Copy $w\n"
9312 "$w delete sel.first sel.last\n"
9313 "}\n"
9314 "}\n"
9315 "proc console:Paste w {\n"
9316 "if {[console:canCut $w]==1} {\n"
9317 "$w delete sel.first sel.last\n"
9318 "}\n"
9319 "if {[catch {selection get -displayof $w -selection CLIPBOARD} topaste]} {\n"
9320 "return\n"
9321 "}\n"
9322 "set prior 0\n"
9323 "foreach line [split $topaste \\n] {\n"
9324 "if {$prior} {\n"
9325 "console:Enter $w\n"
9326 "update\n"
9327 "}\n"
9328 "set prior 1\n"
9329 "$w insert insert $line\n"
9330 "}\n"
9331 "}\n"
9332 "proc console:EnableEditMenu w {\n"
9333 "set m $w.mb.edit.m\n"
9334 "switch [console:canCut $w.t] {\n"
9335 "0 {\n"
9336 "$m entryconf Copy -state disabled\n"
9337 "$m entryconf Cut -state disabled\n"
9338 "}\n"
9339 "1 {\n"
9340 "$m entryconf Copy -state normal\n"
9341 "$m entryconf Cut -state normal\n"
9342 "}\n"
9343 "2 {\n"
9344 "$m entryconf Copy -state normal\n"
9345 "$m entryconf Cut -state disabled\n"
9346 "}\n"
9347 "}\n"
9348 "}\n"
9349 "proc console:SourceFile w {\n"
9350 "set types {\n"
9351 "{{TCL Scripts} {.tcl}}\n"
9352 "{{All Files} *}\n"
9353 "}\n"
9354 "set f [tk_getOpenFile -filetypes $types -title \"TCL Script To Source...\"]\n"
9355 "if {$f!=\"\"} {\n"
9356 "uplevel #0 source $f\n"
9357 "}\n"
9358 "}\n"
9359 "proc console:SaveFile w {\n"
9360 "set types {\n"
9361 "{{Text Files} {.txt}}\n"
9362 "{{All Files} *}\n"
9363 "}\n"
9364 "set f [tk_getSaveFile -filetypes $types -title \"Write Screen To...\"]\n"
9365 "if {$f!=\"\"} {\n"
9366 "if {[catch {open $f w} fd]} {\n"
9367 "tk_messageBox -type ok -icon error -message $fd\n"
9368 "} else {\n"
9369 "puts $fd [string trimright [$w get 1.0 end] \\n]\n"
9370 "close $fd\n"
9371 "}\n"
9372 "}\n"
9373 "}\n"
9374 "proc console:Clear w {\n"
9375 "$w delete 1.0 {insert linestart}\n"
9376 "}\n"
9377 ; /* End of the console code */
9378 #endif /* ET_ENABLE_TK */
9379
9380 /*
9381 ** The "printf" code that follows dates from the 1980's. It is in
9382 ** the public domain. The original comments are included here for
9383 ** completeness. They are slightly out-of-date.
9384 **
9385 ** The following modules is an enhanced replacement for the "printf" programs
9386 ** found in the standard library. The following enhancements are
9387 ** supported:
9388 **
9389 ** + Additional functions. The standard set of "printf" functions
9390 ** includes printf, fprintf, sprintf, vprintf, vfprintf, and
9391 ** vsprintf. This module adds the following:
9392 **
9393 ** * snprintf -- Works like sprintf, but has an extra argument
9394 ** which is the size of the buffer written to.
9395 **
9396 ** * mprintf -- Similar to sprintf. Writes output to memory
9397 ** obtained from malloc.
9398 **
9399 ** * xprintf -- Calls a function to dispose of output.
9400 **
9401 ** * nprintf -- No output, but returns the number of characters
9402 ** that would have been output by printf.
9403 **
9404 ** * A v- version (ex: vsnprintf) of every function is also
9405 ** supplied.
9406 **
9407 ** + A few extensions to the formatting notation are supported:
9408 **
9409 ** * The "=" flag (similar to "-") causes the output to be
9410 ** be centered in the appropriately sized field.
9411 **
9412 ** * The %b field outputs an integer in binary notation.
9413 **
9414 ** * The %c field now accepts a precision. The character output
9415 ** is repeated by the number of times the precision specifies.
9416 **
9417 ** * The %' field works like %c, but takes as its character the
9418 ** next character of the format string, instead of the next
9419 ** argument. For example, printf("%.78'-") prints 78 minus
9420 ** signs, the same as printf("%.78c",'-').
9421 **
9422 ** + When compiled using GCC on a SPARC, this version of printf is
9423 ** faster than the library printf for SUN OS 4.1.
9424 **
9425 ** + All functions are fully reentrant.
9426 **
9427 */
9428 /*
9429 ** Undefine COMPATIBILITY to make some slight changes in the way things
9430 ** work. I think the changes are an improvement, but they are not
9431 ** backwards compatible.
9432 */
9433 /* #define COMPATIBILITY / * Compatible with SUN OS 4.1 */
9434
9435 /*
9436 ** Characters that need to be escaped inside a TCL string.
9437 */
9438 static char NeedEsc[] = {
9439 1, 1, 1, 1, 1, 1, 1, 1, 'b', 't', 'n', 1, 'f', 'r', 1, 1,
9440 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
9441 0, 0, '"', 0, '$', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
9442 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
9443 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
9444 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, '[','\\', ']', 0, 0,
9445 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
9446 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1, 0, 1,
9447 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
9448 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
9449 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
9450 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
9451 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
9452 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
9453 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
9454 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
9455 };
9456
9457 /*
9458 ** Conversion types fall into various categories as defined by the
9459 ** following enumeration.
9460 */
9461 enum et_type { /* The type of the format field */
9462 etRADIX, /* Integer types. %d, %x, %o, and so forth */
9463 etFLOAT, /* Floating point. %f */
9464 etEXP, /* Exponentional notation. %e and %E */
9465 etGENERIC, /* Floating or exponential, depending on exponent. %g */
9466 etSIZE, /* Return number of characters processed so far. %n */
9467 etSTRING, /* Strings. %s */
9468 etPERCENT, /* Percent symbol. %% */
9469 etCHARX, /* Characters. %c */
9470 etERROR, /* Used to indicate no such conversion type */
9471 /* The rest are extensions, not normally found in printf() */
9472 etCHARLIT, /* Literal characters. %' */
9473 etTCLESCAPE, /* Strings with special characters escaped. %q */
9474 etMEMSTRING, /* A string which should be deleted after use. %z */
9475 etORDINAL /* 1st, 2nd, 3rd and so forth */
9476 };
9477
9478 /*
9479 ** Each builtin conversion character (ex: the 'd' in "%d") is described
9480 ** by an instance of the following structure
9481 */
9482 typedef struct et_info { /* Information about each format field */
9483 int fmttype; /* The format field code letter */
9484 int base; /* The base for radix conversion */
9485 char *charset; /* The character set for conversion */
9486 int flag_signed; /* Is the quantity signed? */
9487 char *prefix; /* Prefix on non-zero values in alt format */
9488 enum et_type type; /* Conversion paradigm */
9489 } et_info;
9490
9491 /*
9492 ** The following table is searched linearly, so it is good to put the
9493 ** most frequently used conversion types first.
9494 */
9495 static et_info fmtinfo[] = {
9496 { 'd', 10, "0123456789", 1, 0, etRADIX, },
9497 { 's', 0, 0, 0, 0, etSTRING, },
9498 { 'q', 0, 0, 0, 0, etTCLESCAPE, },
9499 { 'z', 0, 0, 0, 0, etMEMSTRING, },
9500 { 'c', 0, 0, 0, 0, etCHARX, },
9501 { 'o', 8, "01234567", 0, "0", etRADIX, },
9502 { 'u', 10, "0123456789", 0, 0, etRADIX, },
9503 { 'x', 16, "0123456789abcdef", 0, "x0", etRADIX, },
9504 { 'X', 16, "0123456789ABCDEF", 0, "X0", etRADIX, },
9505 { 'r', 10, "0123456789", 0, 0, etORDINAL, },
9506 { 'f', 0, 0, 1, 0, etFLOAT, },
9507 { 'e', 0, "e", 1, 0, etEXP, },
9508 { 'E', 0, "E", 1, 0, etEXP, },
9509 { 'g', 0, "e", 1, 0, etGENERIC, },
9510 { 'G', 0, "E", 1, 0, etGENERIC, },
9511 { 'i', 10, "0123456789", 1, 0, etRADIX, },
9512 { 'n', 0, 0, 0, 0, etSIZE, },
9513 { '%', 0, 0, 0, 0, etPERCENT, },
9514 { 'b', 2, "01", 0, "b0", etRADIX, }, /* Binary */
9515 { 'p', 10, "0123456789", 0, 0, etRADIX, }, /* Pointers */
9516 { '\'', 0, 0, 0, 0, etCHARLIT, }, /* Literal char */
9517 };
9518 #define etNINFO (sizeof(fmtinfo)/sizeof(fmtinfo[0]))
9519
9520 /*
9521 ** If NOFLOATINGPOINT is defined, then none of the floating point
9522 ** conversions will work.
9523 */
9524 #ifndef etNOFLOATINGPOINT
9525 /*
9526 ** "*val" is a double such that 0.1 <= *val < 10.0
9527 ** Return the ascii code for the leading digit of *val, then
9528 ** multiply "*val" by 10.0 to renormalize.
9529 **
9530 ** Example:
9531 ** input: *val = 3.14159
9532 ** output: *val = 1.4159 function return = '3'
9533 **
9534 ** The counter *cnt is incremented each time. After counter exceeds
9535 ** 16 (the number of significant digits in a 64-bit float) '0' is
9536 ** always returned.
9537 */
9538 static int et_getdigit(double *val, int *cnt){
9539 int digit;
9540 double d;
9541 if( (*cnt)++ >= 16 ) return '0';
9542 digit = (int)*val;
9543 d = digit;
9544 digit += '0';
9545 *val = (*val - d)*10.0;
9546 return digit;
9547 }
9548 #endif
9549
9550 #define etBUFSIZE 1000 /* Size of the output buffer */
9551
9552 /*
9553 ** The root program. All variations call this core.
9554 **
9555 ** INPUTS:
9556 ** func This is a pointer to a function taking three arguments
9557 ** 1. A pointer to anything. Same as the "arg" parameter.
9558 ** 2. A pointer to the list of characters to be output
9559 ** (Note, this list is NOT null terminated.)
9560 ** 3. An integer number of characters to be output.
9561 ** (Note: This number might be zero.)
9562 **
9563 ** arg This is the pointer to anything which will be passed as the
9564 ** first argument to "func". Use it for whatever you like.
9565 **
9566 ** fmt This is the format string, as in the usual print.
9567 **
9568 ** ap This is a pointer to a list of arguments. Same as in
9569 ** vfprint.
9570 **
9571 ** OUTPUTS:
9572 ** The return value is the total number of characters sent to
9573 ** the function "func". Returns -1 on a error.
9574 **
9575 ** Note that the order in which automatic variables are declared below
9576 ** seems to make a big difference in determining how fast this beast
9577 ** will run.
9578 */
9579 int vxprintf(
9580 void (*func)(void*,char*,int),
9581 void *arg,
9582 const char *format,
9583 va_list ap
9584 ){
9585 register const char *fmt; /* The format string. */
9586 register int c; /* Next character in the format string */
9587 register char *bufpt; /* Pointer to the conversion buffer */
9588 register int precision; /* Precision of the current field */
9589 register int length; /* Length of the field */
9590 register int idx; /* A general purpose loop counter */
9591 int count; /* Total number of characters output */
9592 int width; /* Width of the current field */
9593 int flag_leftjustify; /* True if "-" flag is present */
9594 int flag_plussign; /* True if "+" flag is present */
9595 int flag_blanksign; /* True if " " flag is present */
9596 int flag_alternateform; /* True if "#" flag is present */
9597 int flag_zeropad; /* True if field width constant starts with zero */
9598 int flag_long; /* True if "l" flag is present */
9599 int flag_center; /* True if "=" flag is present */
9600 unsigned long longvalue; /* Value for integer types */
9601 double realvalue; /* Value for real types */
9602 et_info *infop; /* Pointer to the appropriate info structure */
9603 char buf[etBUFSIZE]; /* Conversion buffer */
9604 char prefix; /* Prefix character. "+" or "-" or " " or '\0'. */
9605 int errorflag = 0; /* True if an error is encountered */
9606 enum et_type xtype; /* Conversion paradigm */
9607 char *zMem; /* String to be freed */
9608 char *zExtra; /* Extra memory used for etTCLESCAPE conversions */
9609 static char spaces[] = " "
9610 " ";
9611 #define etSPACESIZE (sizeof(spaces)-1)
9612 #ifndef etNOFLOATINGPOINT
9613 int exp; /* exponent of real numbers */
9614 double rounder; /* Used for rounding floating point values */
9615 int flag_dp; /* True if decimal point should be shown */
9616 int flag_rtz; /* True if trailing zeros should be removed */
9617 int flag_exp; /* True to force display of the exponent */
9618 int nsd; /* Number of significant digits returned */
9619 #endif
9620
9621 fmt = format; /* Put in a register for speed */
9622 count = length = 0;
9623 bufpt = 0;
9624 for(; (c=(*fmt))!=0; ++fmt){
9625 if( c!='%' ){
9626 register int amt;
9627 bufpt = (char *)fmt;
9628 amt = 1;
9629 while( (c=(*++fmt))!='%' && c!=0 ) amt++;
9630 (*func)(arg,bufpt,amt);
9631 count += amt;
9632 if( c==0 ) break;
9633 }
9634 if( (c=(*++fmt))==0 ){
9635 errorflag = 1;
9636 (*func)(arg,"%",1);
9637 count++;
9638 break;
9639 }
9640 /* Find out what flags are present */
9641 flag_leftjustify = flag_plussign = flag_blanksign =
9642 flag_alternateform = flag_zeropad = flag_center = 0;
9643 do{
9644 switch( c ){
9645 case '-': flag_leftjustify = 1; c = 0; break;
9646 case '+': flag_plussign = 1; c = 0; break;
9647 case ' ': flag_blanksign = 1; c = 0; break;
9648 case '#': flag_alternateform = 1; c = 0; break;
9649 case '0': flag_zeropad = 1; c = 0; break;
9650 case '=': flag_center = 1; c = 0; break;
9651 default: break;
9652 }
9653 }while( c==0 && (c=(*++fmt))!=0 );
9654 if( flag_center ) flag_leftjustify = 0;
9655 /* Get the field width */
9656 width = 0;
9657 if( c=='*' ){
9658 width = va_arg(ap,int);
9659 if( width<0 ){
9660 flag_leftjustify = 1;
9661 width = -width;
9662 }
9663 c = *++fmt;
9664 }else{
9665 while( isdigit(c) ){
9666 width = width*10 + c - '0';
9667 c = *++fmt;
9668 }
9669 }
9670 if( width > etBUFSIZE-10 ){
9671 width = etBUFSIZE-10;
9672 }
9673 /* Get the precision */
9674 if( c=='.' ){
9675 precision = 0;
9676 c = *++fmt;
9677 if( c=='*' ){
9678 precision = va_arg(ap,int);
9679 #ifndef etCOMPATIBILITY
9680 /* This is sensible, but SUN OS 4.1 doesn't do it. */
9681 if( precision<0 ) precision = -precision;
9682 #endif
9683 c = *++fmt;
9684 }else{
9685 while( isdigit(c) ){
9686 precision = precision*10 + c - '0';
9687 c = *++fmt;
9688 }
9689 }
9690 /* Limit the precision to prevent overflowing buf[] during conversion */
9691 if( precision>etBUFSIZE-40 ) precision = etBUFSIZE-40;
9692 }else{
9693 precision = -1;
9694 }
9695 /* Get the conversion type modifier */
9696 if( c=='l' ){
9697 flag_long = 1;
9698 c = *++fmt;
9699 }else{
9700 flag_long = 0;
9701 }
9702 /* Fetch the info entry for the field */
9703 infop = 0;
9704 for(idx=0; idx<etNINFO; idx++){
9705 if( c==fmtinfo[idx].fmttype ){
9706 infop = &fmtinfo[idx];
9707 break;
9708 }
9709 }
9710 /* No info entry found. It must be an error. */
9711 if( infop==0 ){
9712 xtype = etERROR;
9713 }else{
9714 xtype = infop->type;
9715 }
9716 zExtra = 0;
9717
9718 /*
9719 ** At this point, variables are initialized as follows:
9720 **
9721 ** flag_alternateform TRUE if a '#' is present.
9722 ** flag_plussign TRUE if a '+' is present.
9723 ** flag_leftjustify TRUE if a '-' is present or if the
9724 ** field width was negative.
9725 ** flag_zeropad TRUE if the width began with 0.
9726 ** flag_long TRUE if the letter 'l' (ell) prefixed
9727 ** the conversion character.
9728 ** flag_blanksign TRUE if a ' ' is present.
9729 ** width The specified field width. This is
9730 ** always non-negative. Zero is the default.
9731 ** precision The specified precision. The default
9732 ** is -1.
9733 ** xtype The class of the conversion.
9734 ** infop Pointer to the appropriate info struct.
9735 */
9736 switch( xtype ){
9737 case etORDINAL:
9738 case etRADIX:
9739 if( flag_long ) longvalue = va_arg(ap,long);
9740 else longvalue = va_arg(ap,int);
9741 #ifdef etCOMPATIBILITY
9742 /* For the format %#x, the value zero is printed "0" not "0x0".
9743 ** I think this is stupid. */
9744 if( longvalue==0 ) flag_alternateform = 0;
9745 #else
9746 /* More sensible: turn off the prefix for octal (to prevent "00"),
9747 ** but leave the prefix for hex. */
9748 if( longvalue==0 && infop->base==8 ) flag_alternateform = 0;
9749 #endif
9750 if( infop->flag_signed ){
9751 if( *(long*)&longvalue<0 ){
9752 longvalue = -*(long*)&longvalue;
9753 prefix = '-';
9754 }else if( flag_plussign ) prefix = '+';
9755 else if( flag_blanksign ) prefix = ' ';
9756 else prefix = 0;
9757 }else prefix = 0;
9758 if( flag_zeropad && precision<width-(prefix!=0) ){
9759 precision = width-(prefix!=0);
9760 }
9761 bufpt = &buf[etBUFSIZE];
9762 if( xtype==etORDINAL ){
9763 long a,b;
9764 a = longvalue%10;
9765 b = longvalue%100;
9766 bufpt -= 2;
9767 if( a==0 || a>3 || (b>10 && b<14) ){
9768 bufpt[0] = 't';
9769 bufpt[1] = 'h';
9770 }else if( a==1 ){
9771 bufpt[0] = 's';
9772 bufpt[1] = 't';
9773 }else if( a==2 ){
9774 bufpt[0] = 'n';
9775 bufpt[1] = 'd';
9776 }else if( a==3 ){
9777 bufpt[0] = 'r';
9778 bufpt[1] = 'd';
9779 }
9780 }
9781 {
9782 register char *cset; /* Use registers for speed */
9783 register int base;
9784 cset = infop->charset;
9785 base = infop->base;
9786 do{ /* Convert to ascii */
9787 *(--bufpt) = cset[longvalue%base];
9788 longvalue = longvalue/base;
9789 }while( longvalue>0 );
9790 }
9791 length = (long)&buf[etBUFSIZE]-(long)bufpt;
9792 for(idx=precision-length; idx>0; idx--){
9793 *(--bufpt) = '0'; /* Zero pad */
9794 }
9795 if( prefix ) *(--bufpt) = prefix; /* Add sign */
9796 if( flag_alternateform && infop->prefix ){ /* Add "0" or "0x" */
9797 char *pre, x;
9798 pre = infop->prefix;
9799 if( *bufpt!=pre[0] ){
9800 for(pre=infop->prefix; (x=(*pre))!=0; pre++) *(--bufpt) = x;
9801 }
9802 }
9803 length = (long)&buf[etBUFSIZE]-(long)bufpt;
9804 break;
9805 case etFLOAT:
9806 case etEXP:
9807 case etGENERIC:
9808 realvalue = va_arg(ap,double);
9809 #ifndef etNOFLOATINGPOINT
9810 if( precision<0 ) precision = 6; /* Set default precision */
9811 if( precision>etBUFSIZE-10 ) precision = etBUFSIZE-10;
9812 if( realvalue<0.0 ){
9813 realvalue = -realvalue;
9814 prefix = '-';
9815 }else{
9816 if( flag_plussign ) prefix = '+';
9817 else if( flag_blanksign ) prefix = ' ';
9818 else prefix = 0;
9819 }
9820 if( infop->type==etGENERIC && precision>0 ) precision--;
9821 rounder = 0.0;
9822 #ifdef COMPATIBILITY
9823 /* Rounding works like BSD when the constant 0.4999 is used. Wierd! */
9824 for(idx=precision, rounder=0.4999; idx>0; idx--, rounder*=0.1);
9825 #else
9826 /* It makes more sense to use 0.5 */
9827 for(idx=precision, rounder=0.5; idx>0; idx--, rounder*=0.1);
9828 #endif
9829 if( infop->type==etFLOAT ) realvalue += rounder;
9830 /* Normalize realvalue to within 10.0 > realvalue >= 1.0 */
9831 exp = 0;
9832 if( realvalue>0.0 ){
9833 int k = 0;
9834 while( realvalue>=1e8 && k++<100 ){ realvalue *= 1e-8; exp+=8; }
9835 while( realvalue>=10.0 && k++<100 ){ realvalue *= 0.1; exp++; }
9836 while( realvalue<1e-8 && k++<100 ){ realvalue *= 1e8; exp-=8; }
9837 while( realvalue<1.0 && k++<100 ){ realvalue *= 10.0; exp--; }
9838 if( k>=100 ){
9839 bufpt = "NaN";
9840 length = 3;
9841 break;
9842 }
9843 }
9844 bufpt = buf;
9845 /*
9846 ** If the field type is etGENERIC, then convert to either etEXP
9847 ** or etFLOAT, as appropriate.
9848 */
9849 flag_exp = xtype==etEXP;
9850 if( xtype!=etFLOAT ){
9851 realvalue += rounder;
9852 if( realvalue>=10.0 ){ realvalue *= 0.1; exp++; }
9853 }
9854 if( xtype==etGENERIC ){
9855 flag_rtz = !flag_alternateform;
9856 if( exp<-4 || exp>precision ){
9857 xtype = etEXP;
9858 }else{
9859 precision = precision - exp;
9860 xtype = etFLOAT;
9861 }
9862 }else{
9863 flag_rtz = 0;
9864 }
9865 /*
9866 ** The "exp+precision" test causes output to be of type etEXP if
9867 ** the precision is too large to fit in buf[].
9868 */
9869 nsd = 0;
9870 if( xtype==etFLOAT && exp+precision<etBUFSIZE-30 ){
9871 flag_dp = (precision>0 || flag_alternateform);
9872 if( prefix ) *(bufpt++) = prefix; /* Sign */
9873 if( exp<0 ) *(bufpt++) = '0'; /* Digits before "." */
9874 else for(; exp>=0; exp--) *(bufpt++) = et_getdigit(&realvalue,&nsd);
9875 if( flag_dp ) *(bufpt++) = '.'; /* The decimal point */
9876 for(exp++; exp<0 && precision>0; precision--, exp++){
9877 *(bufpt++) = '0';
9878 }
9879 while( (precision--)>0 ) *(bufpt++) = et_getdigit(&realvalue,&nsd);
9880 *(bufpt--) = 0; /* Null terminate */
9881 if( flag_rtz && flag_dp ){ /* Remove trailing zeros and "." */
9882 while( bufpt>=buf && *bufpt=='0' ) *(bufpt--) = 0;
9883 if( bufpt>=buf && *bufpt=='.' ) *(bufpt--) = 0;
9884 }
9885 bufpt++; /* point to next free slot */
9886 }else{ /* etEXP or etGENERIC */
9887 flag_dp = (precision>0 || flag_alternateform);
9888 if( prefix ) *(bufpt++) = prefix; /* Sign */
9889 *(bufpt++) = et_getdigit(&realvalue,&nsd); /* First digit */
9890 if( flag_dp ) *(bufpt++) = '.'; /* Decimal point */
9891 while( (precision--)>0 ) *(bufpt++) = et_getdigit(&realvalue,&nsd);
9892 bufpt--; /* point to last digit */
9893 if( flag_rtz && flag_dp ){ /* Remove tail zeros */
9894 while( bufpt>=buf && *bufpt=='0' ) *(bufpt--) = 0;
9895 if( bufpt>=buf && *bufpt=='.' ) *(bufpt--) = 0;
9896 }
9897 bufpt++; /* point to next free slot */
9898 if( exp || flag_exp ){
9899 *(bufpt++) = infop->charset[0];
9900 if( exp<0 ){ *(bufpt++) = '-'; exp = -exp; } /* sign of exp */
9901 else { *(bufpt++) = '+'; }
9902 if( exp>=100 ){
9903 *(bufpt++) = (exp/100)+'0'; /* 100's digit */
9904 exp %= 100;
9905 }
9906 *(bufpt++) = exp/10+'0'; /* 10's digit */
9907 *(bufpt++) = exp%10+'0'; /* 1's digit */
9908 }
9909 }
9910 /* The converted number is in buf[] and zero terminated. Output it.
9911 ** Note that the number is in the usual order, not reversed as with
9912 ** integer conversions. */
9913 length = (long)bufpt-(long)buf;
9914 bufpt = buf;
9915
9916 /* Special case: Add leading zeros if the flag_zeropad flag is
9917 ** set and we are not left justified */
9918 if( flag_zeropad && !flag_leftjustify && length < width){
9919 int i;
9920 int nPad = width - length;
9921 for(i=width; i>=nPad; i--){
9922 bufpt[i] = bufpt[i-nPad];
9923 }
9924 i = prefix!=0;
9925 while( nPad-- ) bufpt[i++] = '0';
9926 length = width;
9927 }
9928 #endif
9929 break;
9930 case etSIZE:
9931 *(va_arg(ap,int*)) = count;
9932 length = width = 0;
9933 break;
9934 case etPERCENT:
9935 buf[0] = '%';
9936 bufpt = buf;
9937 length = 1;
9938 break;
9939 case etCHARLIT:
9940 case etCHARX:
9941 c = buf[0] = (xtype==etCHARX ? va_arg(ap,int) : *++fmt);
9942 if( precision>=0 ){
9943 for(idx=1; idx<precision; idx++) buf[idx] = c;
9944 length = precision;
9945 }else{
9946 length =1;
9947 }
9948 bufpt = buf;
9949 break;
9950 case etSTRING:
9951 case etMEMSTRING:
9952 zMem = bufpt = va_arg(ap,char*);
9953 if( bufpt==0 ) bufpt = "(null)";
9954 length = strlen(bufpt);
9955 if( precision>=0 && precision<length ) length = precision;
9956 break;
9957 case etTCLESCAPE:
9958 {
9959 int i, j, n, c, k;
9960 char *arg = va_arg(ap,char*);
9961 if( arg==0 ) arg = "(NULL)";
9962 for(i=n=0; (c=arg[i])!=0; i++){
9963 k = NeedEsc[c&0xff];
9964 if( k==0 ){
9965 n++;
9966 }else if( k==1 ){
9967 n+=4;
9968 }else{
9969 n+=2;
9970 }
9971 }
9972 n++;
9973 if( n>etBUFSIZE ){
9974 bufpt = zExtra = Tcl_Alloc( n );
9975 }else{
9976 bufpt = buf;
9977 }
9978 for(i=j=0; (c=arg[i])!=0; i++){
9979 k = NeedEsc[c&0xff];
9980 if( k==0 ){
9981 bufpt[j++] = c;
9982 }else if( k==1 ){
9983 bufpt[j++] = '\\';
9984 bufpt[j++] = ((c>>6) & 3) + '0';
9985 bufpt[j++] = ((c>>3) & 7) + '0';
9986 bufpt[j++] = (c & 7) + '0';
9987 }else{
9988 bufpt[j++] = '\\';
9989 bufpt[j++] = k;
9990 }
9991 }
9992 bufpt[j] = 0;
9993 length = j;
9994 if( precision>=0 && precision<length ) length = precision;
9995 }
9996 break;
9997 case etERROR:
9998 buf[0] = '%';
9999 buf[1] = c;
10000 errorflag = 0;
10001 idx = 1+(c!=0);
10002 (*func)(arg,"%",idx);
10003 count += idx;
10004 if( c==0 ) fmt--;
10005 break;
10006 }/* End switch over the format type */
10007 /*
10008 ** The text of the conversion is pointed to by "bufpt" and is
10009 ** "length" characters long. The field width is "width". Do
10010 ** the output.
10011 */
10012 if( !flag_leftjustify ){
10013 register int nspace;
10014 nspace = width-length;
10015 if( nspace>0 ){
10016 if( flag_center ){
10017 nspace = nspace/2;
10018 width -= nspace;
10019 flag_leftjustify = 1;
10020 }
10021 count += nspace;
10022 while( nspace>=etSPACESIZE ){
10023 (*func)(arg,spaces,etSPACESIZE);
10024 nspace -= etSPACESIZE;
10025 }
10026 if( nspace>0 ) (*func)(arg,spaces,nspace);
10027 }
10028 }
10029 if( length>0 ){
10030 (*func)(arg,bufpt,length);
10031 count += length;
10032 }
10033 if( xtype==etMEMSTRING && zMem ){
10034 Tcl_Free(zMem);
10035 }
10036 if( flag_leftjustify ){
10037 register int nspace;
10038 nspace = width-length;
10039 if( nspace>0 ){
10040 count += nspace;
10041 while( nspace>=etSPACESIZE ){
10042 (*func)(arg,spaces,etSPACESIZE);
10043 nspace -= etSPACESIZE;
10044 }
10045 if( nspace>0 ) (*func)(arg,spaces,nspace);
10046 }
10047 }
10048 if( zExtra ){
10049 Tcl_Free(zExtra);
10050 }
10051 }/* End for loop over the format string */
10052 return errorflag ? -1 : count;
10053 } /* End of function */
10054
10055 /*
10056 ** The following section of code handles the mprintf routine, that
10057 ** writes to memory obtained from malloc().
10058 */
10059
10060 /* This structure is used to store state information about the
10061 ** write to memory that is currently in progress.
10062 */
10063 struct sgMprintf {
10064 char *zBase; /* A base allocation */
10065 char *zText; /* The string collected so far */
10066 int nChar; /* Length of the string so far */
10067 int nAlloc; /* Amount of space allocated in zText */
10068 };
10069
10070 /*
10071 ** The xprintf callback function.
10072 **
10073 ** This routine add nNewChar characters of text in zNewText to
10074 ** the sgMprintf structure pointed to by "arg".
10075 */
10076 static void mout(void *arg, char *zNewText, int nNewChar){
10077 struct sgMprintf *pM = (struct sgMprintf*)arg;
10078 if( pM->nChar + nNewChar + 1 > pM->nAlloc ){
10079 pM->nAlloc = pM->nChar + nNewChar*2 + 1;
10080 if( pM->zText==pM->zBase ){
10081 pM->zText = Tcl_Alloc(pM->nAlloc);
10082 if( pM->zText && pM->nChar ) memcpy(pM->zText,pM->zBase,pM->nChar);
10083 }else{
10084 pM->zText = Tcl_Realloc(pM->zText, pM->nAlloc);
10085 }
10086 }
10087 if( pM->zText ){
10088 memcpy(&pM->zText[pM->nChar], zNewText, nNewChar);
10089 pM->nChar += nNewChar;
10090 pM->zText[pM->nChar] = 0;
10091 }
10092 }
10093
10094 /*
10095 ** mprintf() works like printf(), but allocations memory to hold the
10096 ** resulting string and returns a pointer to the allocated memory.
10097 */
10098 char *mprintf(const char *zFormat, ...){
10099 va_list ap;
10100 struct sgMprintf sMprintf;
10101 char *zNew;
10102 char zBuf[200];
10103
10104 sMprintf.nChar = 0;
10105 sMprintf.nAlloc = sizeof(zBuf);
10106 sMprintf.zText = zBuf;
10107 sMprintf.zBase = zBuf;
10108 va_start(ap,zFormat);
10109 vxprintf(mout,&sMprintf,zFormat,ap);
10110 va_end(ap);
10111 sMprintf.zText[sMprintf.nChar] = 0;
10112 if( sMprintf.zText==sMprintf.zBase ){
10113 zNew = Tcl_Alloc( sMprintf.nChar+1 );
10114 if( zNew ) strcpy(zNew,zBuf);
10115 }else{
10116 zNew = Tcl_Realloc(sMprintf.zText,sMprintf.nChar+1);
10117 }
10118 return zNew;
10119 }
10120
10121 /* This is the varargs version of mprintf.
10122 */
10123 char *vmprintf(const char *zFormat, va_list ap){
10124 struct sgMprintf sMprintf;
10125 char zBuf[200];
10126 sMprintf.nChar = 0;
10127 sMprintf.zText = zBuf;
10128 sMprintf.nAlloc = sizeof(zBuf);
10129 sMprintf.zBase = zBuf;
10130 vxprintf(mout,&sMprintf,zFormat,ap);
10131 sMprintf.zText[sMprintf.nChar] = 0;
10132 if( sMprintf.zText==sMprintf.zBase ){
10133 sMprintf.zText = Tcl_Alloc( strlen(zBuf)+1 );
10134 if( sMprintf.zText ) strcpy(sMprintf.zText,zBuf);
10135 }else{
10136 sMprintf.zText = Tcl_Realloc(sMprintf.zText,sMprintf.nChar+1);
10137 }
10138 return sMprintf.zText;
10139 }
10140
10141 /*
10142 ** Add text output to a Tcl_DString.
10143 **
10144 ** This routine is called by vxprintf(). It's job is to add
10145 ** nNewChar characters of text from zNewText to the Tcl_DString
10146 ** that "arg" is pointing to.
10147 */
10148 static void dstringout(void *arg, char *zNewText, int nNewChar){
10149 Tcl_DString *str = (Tcl_DString*)arg;
10150 Tcl_DStringAppend(str,zNewText,nNewChar);
10151 }
10152
10153 /*
10154 ** Append formatted output to a DString.
10155 */
10156 char *Et_DStringAppendF(Tcl_DString *str, const char *zFormat, ...){
10157 va_list ap;
10158 va_start(ap,zFormat);
10159 vxprintf(dstringout,str,zFormat,ap);
10160 va_end(ap);
10161 return Tcl_DStringValue(str);
10162 }
10163
10164 /*
10165 ** Make this variable true to trace all calls to EvalF
10166 */
10167 int Et_EvalTrace = 0;
10168
10169 /*
10170 ** Eval the results of a string.
10171 */
10172 int Et_EvalF(Tcl_Interp *interp, const char *zFormat, ...){
10173 char *zCmd;
10174 va_list ap;
10175 int result;
10176 va_start(ap,zFormat);
10177 zCmd = vmprintf(zFormat,ap);
10178 if( Et_EvalTrace ) printf("%s\n",zCmd);
10179 result = Tcl_Eval(interp,zCmd);
10180 if( Et_EvalTrace ) printf("%d %s\n",result,Tcl_GetStringResult(interp));
10181 Tcl_Free(zCmd);
10182 return result;
10183 }
10184 int Et_GlobalEvalF(Tcl_Interp *interp, const char *zFormat, ...){
10185 char *zCmd;
10186 va_list ap;
10187 int result;
10188 va_start(ap,zFormat);
10189 zCmd = vmprintf(zFormat,ap);
10190 if( Et_EvalTrace ) printf("%s\n",zCmd);
10191 result = Tcl_GlobalEval(interp,zCmd);
10192 if( Et_EvalTrace ) printf("%d %s\n",result,Tcl_GetStringResult(interp));
10193 Tcl_Free(zCmd);
10194 return result;
10195 }
10196
10197 /*
10198 ** Set the result of an interpreter using printf-like arguments.
10199 */
10200 void Et_ResultF(Tcl_Interp *interp, const char *zFormat, ...){
10201 Tcl_DString str;
10202 va_list ap;
10203
10204 Tcl_DStringInit(&str);
10205 va_start(ap,zFormat);
10206 vxprintf(dstringout,&str,zFormat,ap);
10207 va_end(ap);
10208 Tcl_DStringResult(interp,&str);
10209 }
10210
10211 #if ET_HAVE_OBJ
10212 /*
10213 ** Append text to a string object.
10214 */
10215 int Et_AppendObjF(Tcl_Obj *pObj, const char *zFormat, ...){
10216 va_list ap;
10217 int rc;
10218
10219 va_start(ap,zFormat);
10220 rc = vxprintf((void(*)(void*,char*,int))Tcl_AppendToObj, pObj, zFormat, ap);
10221 va_end(ap);
10222 return rc;
10223 }
10224 #endif
10225
10226
10227 #if ET_WIN32
10228 /*
10229 ** This array translates all characters into themselves. Except
10230 ** for the \ which gets translated into /. And all upper-case
10231 ** characters are translated into lower case. This is used for
10232 ** hashing and comparing filenames, to work around the Windows
10233 ** bug of ignoring filename case and using the wrong separator
10234 ** character for directories.
10235 **
10236 ** The array is initialized by FilenameHashInit().
10237 **
10238 ** We also define a macro ET_TRANS() that actually does
10239 ** the character translation. ET_TRANS() is a no-op under
10240 ** unix.
10241 */
10242 static char charTrans[256];
10243 #define ET_TRANS(X) (charTrans[0xff&(int)(X)])
10244 #else
10245 #define ET_TRANS(X) (X)
10246 #endif
10247
10248 /*
10249 ** Hash a filename. The value returned is appropriate for
10250 ** indexing into the Et_FileHashTable[] array.
10251 */
10252 static int FilenameHash(char *zName){
10253 int h = 0;
10254 while( *zName ){
10255 h = h ^ (h<<5) ^ ET_TRANS(*(zName++));
10256 }
10257 if( h<0 ) h = -h;
10258 return h % (sizeof(Et_FileHashTable)/sizeof(Et_FileHashTable[0]));
10259 }
10260
10261 /*
10262 ** Compare two filenames. Return 0 if they are the same and
10263 ** non-zero if they are different.
10264 */
10265 static int FilenameCmp(char *z1, char *z2){
10266 int diff;
10267 while( (diff = ET_TRANS(*z1)-ET_TRANS(*z2))==0 && *z1!=0){
10268 z1++;
10269 z2++;
10270 }
10271 return diff;
10272 }
10273
10274 /*
10275 ** Initialize the file hash table
10276 */
10277 static void FilenameHashInit(void){
10278 int i;
10279 #if ET_WIN32
10280 for(i=0; i<sizeof(charTrans); i++){
10281 charTrans[i] = i;
10282 }
10283 for(i='A'; i<='Z'; i++){
10284 charTrans[i] = i + 'a' - 'A';
10285 }
10286 charTrans['\\'] = '/';
10287 #endif
10288 for(i=0; i<sizeof(Et_FileSet)/sizeof(Et_FileSet[0]) - 1; i++){
10289 struct EtFile *p;
10290 int h;
10291 p = &Et_FileSet[i];
10292 h = FilenameHash(p->zName);
10293 p->pNext = Et_FileHashTable[h];
10294 Et_FileHashTable[h] = p;
10295 }
10296 }
10297
10298 /*
10299 ** Locate the text of a built-in file given its name.
10300 ** Return 0 if not found. Return this size of the file (not
10301 ** counting the null-terminator) in *pSize if pSize!=NULL.
10302 **
10303 ** If deshroud==1 and the file is shrouded, then descramble
10304 ** the text.
10305 */
10306 static char *FindBuiltinFile(char *zName, int deshroud, int *pSize){
10307 int h;
10308 struct EtFile *p;
10309
10310 h = FilenameHash(zName);
10311 p = Et_FileHashTable[h];
10312 while( p && FilenameCmp(p->zName,zName)!=0 ){ p = p->pNext; }
10313 #if ET_SHROUD_KEY>0
10314 if( p && p->shrouded && deshroud ){
10315 char *z;
10316 int xor = ET_SHROUD_KEY;
10317 for(z=p->zData; *z; z++){
10318 if( *z>=0x20 ){ *z ^= xor; xor = (xor+1)&0x1f; }
10319 }
10320 p->shrouded = 0;
10321 }
10322 #endif
10323 if( p && pSize ){
10324 *pSize = p->nData;
10325 }
10326 return p ? p->zData : 0;
10327 }
10328
10329 /*
10330 ** Add a new file to the list of built-in files.
10331 **
10332 ** This routine makes a copy of zFilename. But it does NOT make
10333 ** a copy of zData. It just holds a pointer to zData and uses
10334 ** that for all file access. So after calling this routine,
10335 ** you should never change zData!
10336 */
10337 void Et_NewBuiltinFile(
10338 char *zFilename, /* Name of the new file */
10339 char *zData, /* Data for the new file */
10340 int nData /* Number of bytes in the new file */
10341 ){
10342 int h;
10343 struct EtFile *p;
10344
10345 p = (struct EtFile*)Tcl_Alloc( sizeof(struct EtFile) + strlen(zFilename) + 1);
10346 if( p==0 ) return;
10347 p->zName = (char*)&p[1];
10348 strcpy(p->zName, zFilename);
10349 p->zData = zData;
10350 p->nData = nData;
10351 p->shrouded = 0;
10352 h = FilenameHash(zFilename);
10353 p->pNext = Et_FileHashTable[h];
10354 Et_FileHashTable[h] = p;
10355 }
10356
10357 /*
10358 ** A TCL interface to the Et_NewBuiltinFile function. For Tcl8.0
10359 ** and later, we make this an Obj command so that it can deal with
10360 ** binary data.
10361 */
10362 #if ET_HAVE_OBJ
10363 static int Et_NewBuiltinFileCmd(ET_OBJARGS){
10364 char *zData, *zNew;
10365 int nData;
10366 if( objc!=3 ){
10367 Tcl_WrongNumArgs(interp, 1, objv, "filename data");
10368 return TCL_ERROR;
10369 }
10370 zData = (char*)Tcl_GetByteArrayFromObj(objv[2], &nData);
10371 zNew = Tcl_Alloc( nData + 1 );
10372 if( zNew ){
10373 memcpy(zNew, zData, nData);
10374 zNew[nData] = 0;
10375 Et_NewBuiltinFile(Tcl_GetStringFromObj(objv[1], 0), zNew, nData);
10376 }
10377 return TCL_OK;
10378 }
10379 #else
10380 static int Et_NewBuiltinFileCmd(ET_TCLARGS){
10381 char *zData;
10382 int nData;
10383 if( argc!=3 ){
10384 Et_ResultF(interp,"wrong # args: should be \"%s FILENAME DATA\"", argv[0]);
10385 return TCL_ERROR;
10386 }
10387 nData = strlen(argv[2]) + 1;
10388 zData = Tcl_Alloc( nData );
10389 if( zData ){
10390 strcpy(zData, argv[2]);
10391 Et_NewBuiltinFile(argv[1], zData, nData);
10392 }
10393 return TCL_OK;
10394 }
10395 #endif
10396
10397 /*
10398 ** The following section implements the InsertProc functionality. The
10399 ** new InsertProc feature of Tcl8.0.3 and later allows us to overload
10400 ** the usual system call commands for file I/O and replace them with
10401 ** commands that operate on the built-in files.
10402 */
10403 #ifdef ET_HAVE_INSERTPROC
10404
10405 /*
10406 ** Each open channel to a built-in file is an instance of the
10407 ** following structure.
10408 */
10409 typedef struct Et_FileStruct {
10410 char *zData; /* All of the data */
10411 int nData; /* Bytes of data, not counting the null terminator */
10412 int cursor; /* How much of the data has been read so far */
10413 } Et_FileStruct;
10414
10415 /*
10416 ** Close a previously opened built-in file.
10417 */
10418 static int Et_FileClose(ClientData instanceData, Tcl_Interp *interp){
10419 Et_FileStruct *p = (Et_FileStruct*)instanceData;
10420 Tcl_Free((char*)p);
10421 return 0;
10422 }
10423
10424 /*
10425 ** Read from a built-in file.
10426 */
10427 static int Et_FileInput(
10428 ClientData instanceData, /* The file structure */
10429 char *buf, /* Write the data read here */
10430 int bufSize, /* Read this much data */
10431 int *pErrorCode /* Write the error code here */
10432 ){
10433 Et_FileStruct *p = (Et_FileStruct*)instanceData;
10434 *pErrorCode = 0;
10435 if( p->cursor+bufSize>p->nData ){
10436 bufSize = p->nData - p->cursor;
10437 }
10438 memcpy(buf, &p->zData[p->cursor], bufSize);
10439 p->cursor += bufSize;
10440 return bufSize;
10441 }
10442
10443 /*
10444 ** Writes to a built-in file always return EOF.
10445 */
10446 static int Et_FileOutput(
10447 ClientData instanceData, /* The file structure */
10448 char *buf, /* Read the data from here */
10449 int toWrite, /* Write this much data */
10450 int *pErrorCode /* Write the error code here */
10451 ){
10452 *pErrorCode = 0;
10453 return 0;
10454 }
10455
10456 /*
10457 ** Move the cursor around within the built-in file.
10458 */
10459 static int Et_FileSeek(
10460 ClientData instanceData, /* The file structure */
10461 long offset, /* Offset to seek to */
10462 int mode, /* One of SEEK_CUR, SEEK_SET or SEEK_END */
10463 int *pErrorCode /* Write the error code here */
10464 ){
10465 Et_FileStruct *p = (Et_FileStruct*)instanceData;
10466 switch( mode ){
10467 case SEEK_CUR: offset += p->cursor; break;
10468 case SEEK_END: offset += p->nData; break;
10469 default: break;
10470 }
10471 if( offset<0 ) offset = 0;
10472 if( offset>p->nData ) offset = p->nData;
10473 p->cursor = offset;
10474 return offset;
10475 }
10476
10477 /*
10478 ** The Watch method is a no-op
10479 */
10480 static void Et_FileWatch(ClientData instanceData, int mask){
10481 }
10482
10483 /*
10484 ** The Handle method always returns an error.
10485 */
10486 static int Et_FileHandle(ClientData notUsed, int dir, ClientData *handlePtr){
10487 return TCL_ERROR;
10488 }
10489
10490 /*
10491 ** This is the channel type that will access the built-in files.
10492 */
10493 static Tcl_ChannelType builtinChannelType = {
10494 "builtin", /* Type name. */
10495 NULL, /* Always non-blocking.*/
10496 Et_FileClose, /* Close proc. */
10497 Et_FileInput, /* Input proc. */
10498 Et_FileOutput, /* Output proc. */
10499 Et_FileSeek, /* Seek proc. */
10500 NULL, /* Set option proc. */
10501 NULL, /* Get option proc. */
10502 Et_FileWatch, /* Watch for events on console. */
10503 Et_FileHandle, /* Get a handle from the device. */
10504 };
10505
10506 /*
10507 ** This routine attempts to do an open of a built-in file.
10508 */
10509 static Tcl_Channel Et_FileOpen(
10510 Tcl_Interp *interp, /* The TCL interpreter doing the open */
10511 char *zFilename, /* Name of the file to open */
10512 char *modeString, /* Mode string for the open (ignored) */
10513 int permissions /* Permissions for a newly created file (ignored) */
10514 ){
10515 char *zData;
10516 Et_FileStruct *p;
10517 int nData;
10518 char zName[50];
10519 Tcl_Channel chan;
10520 static int count = 1;
10521
10522 zData = FindBuiltinFile(zFilename, 1, &nData);
10523 if( zData==0 ) return NULL;
10524 p = (Et_FileStruct*)Tcl_Alloc( sizeof(Et_FileStruct) );
10525 if( p==0 ) return NULL;
10526 p->zData = zData;
10527 p->nData = nData;
10528 p->cursor = 0;
10529 sprintf(zName,"etbi_%x_%x",((int)Et_FileOpen)>>12,count++);
10530 chan = Tcl_CreateChannel(&builtinChannelType, zName,
10531 (ClientData)p, TCL_READABLE);
10532 return chan;
10533 }
10534
10535 /*
10536 ** This routine does a stat() system call for a built-in file.
10537 */
10538 static int Et_FileStat(char *path, struct stat *buf){
10539 char *zData;
10540 int nData;
10541
10542 zData = FindBuiltinFile(path, 0, &nData);
10543 if( zData==0 ){
10544 return -1;
10545 }
10546 memset(buf, 0, sizeof(*buf));
10547 buf->st_mode = 0400;
10548 buf->st_size = nData;
10549 return 0;
10550 }
10551
10552 /*
10553 ** This routien does an access() system call for a built-in file.
10554 */
10555 static int Et_FileAccess(char *path, int mode){
10556 char *zData;
10557
10558 if( mode & 3 ){
10559 return -1;
10560 }
10561 zData = FindBuiltinFile(path, 0, 0);
10562 if( zData==0 ){
10563 return -1;
10564 }
10565 return 0;
10566 }
10567 #endif /* ET_HAVE_INSERTPROC */
10568
10569 /*
10570 ** An overloaded version of "source". First check for the file
10571 ** is one of the built-ins. If it isn't a built-in, then check the
10572 ** disk. But if ET_STANDALONE is set (which corresponds to the
10573 ** "Strict" option in the user interface) then never check the disk.
10574 ** This gives us a quick way to check for the common error of
10575 ** sourcing a file that exists on the development by mistake,
10576 ** and only discovering the mistake when you move the program
10577 ** to your customer's machine.
10578 */
10579 static int Et_Source(ET_TCLARGS){
10580 char *z;
10581
10582 if( argc!=2 ){
10583 Et_ResultF(interp,"wrong # args: should be \"%s FILENAME\"", argv[0]);
10584 return TCL_ERROR;
10585 }
10586 z = FindBuiltinFile(argv[1], 1, 0);
10587 if( z ){
10588 int rc;
10589 rc = Tcl_Eval(interp,z);
10590 if (rc == TCL_ERROR) {
10591 char msg[200];
10592 sprintf(msg, "\n (file \"%.150s\" line %d)", argv[1],
10593 interp->errorLine);
10594 Tcl_AddErrorInfo(interp, msg);
10595 } else {
10596 rc = TCL_OK;
10597 }
10598 return rc;
10599 }
10600 #if ET_STANDALONE
10601 Et_ResultF(interp,"no such file: \"%s\"", argv[1]);
10602 return TCL_ERROR;
10603 #else
10604 return Tcl_EvalFile(interp,argv[1]);
10605 #endif
10606 }
10607
10608 #ifndef ET_HAVE_INSERTPROC
10609 /*
10610 ** An overloaded version of "file exists". First check for the file
10611 ** in the file table, then go to disk.
10612 **
10613 ** We only overload "file exists" if we don't have InsertProc()
10614 ** procedures. If we do have InsertProc() procedures, they will
10615 ** handle this more efficiently.
10616 */
10617 static int Et_FileExists(ET_TCLARGS){
10618 int i, rc;
10619 Tcl_DString str;
10620 if( argc==3 && strncmp(argv[1],"exis",4)==0 ){
10621 if( FindBuiltinFile(argv[2], 0, 0)!=0 ){
10622 Tcl_SetResult(interp, "1", TCL_STATIC);
10623 return TCL_OK;
10624 }
10625 }
10626 Tcl_DStringInit(&str);
10627 Tcl_DStringAppendElement(&str,"Et_FileCmd");
10628 for(i=1; i<argc; i++){
10629 Tcl_DStringAppendElement(&str, argv[i]);
10630 }
10631 rc = Tcl_Eval(interp, Tcl_DStringValue(&str));
10632 Tcl_DStringFree(&str);
10633 return rc;
10634 }
10635 #endif
10636
10637 /*
10638 ** This is the main Tcl interpreter. It's a global variable so it
10639 ** can be accessed easily from C code.
10640 */
10641 Tcl_Interp *Et_Interp = 0;
10642
10643
10644 #if ET_WIN32
10645 /*
10646 ** Implement the Et_MessageBox command on Windows platforms. We
10647 ** use the MessageBox() function from the Win32 API so that the
10648 ** error message will be displayed as a dialog box. Writing to
10649 ** standard error doesn't do anything on windows.
10650 */
10651 int Et_MessageBox(ET_TCLARGS){
10652 char *zMsg = "(Empty Message)";
10653 char *zTitle = "Message...";
10654
10655 if( argc>1 ){
10656 zTitle = argv[1];
10657 }
10658 if( argc>2 ){
10659 zMsg = argv[2];
10660 }
10661 MessageBox(0, zMsg, zTitle, MB_ICONSTOP | MB_OK);
10662 return TCL_OK;
10663 }
10664 #endif
10665
10666 /*
10667 ** A default implementation for "bgerror"
10668 */
10669 static char zBgerror[] =
10670 "proc Et_Bgerror err {\n"
10671 " global errorInfo tk_library\n"
10672 " if {[info exists errorInfo]} {\n"
10673 " set ei $errorInfo\n"
10674 " } else {\n"
10675 " set ei {}\n"
10676 " }\n"
10677 " if {[catch {bgerror $err}]==0} return\n"
10678 " if {[string length $ei]>0} {\n"
10679 " set err $ei\n"
10680 " }\n"
10681 " if {[catch {Et_MessageBox {Error} $err}]} {\n"
10682 " puts stderr $err\n"
10683 " }\n"
10684 " exit\n"
10685 "}\n"
10686 ;
10687
10688 /*
10689 ** Do the initialization.
10690 **
10691 ** This routine is called after the interpreter is created, but
10692 ** before Et_PreInit() or Et_AppInit() have been run.
10693 */
10694 int Et_DoInit(Tcl_Interp *interp){
10695 extern int Et_PreInit(Tcl_Interp*);
10696 extern int Et_AppInit(Tcl_Interp*);
10697
10698
10699 /* Insert our alternative stat(), access() and open() procedures
10700 ** so that any attempt to work with a file will check our built-in
10701 ** scripts first.
10702 */
10703 TclStatInsertProc(Et_FileStat);
10704 TclAccessInsertProc(Et_FileAccess);
10705 TclOpenFileChannelInsertProc(Et_FileOpen);
10706
10707 /* Initialize the hash-table for built-in scripts
10708 */
10709 FilenameHashInit();
10710
10711
10712 /* Overload the "file" and "source" commands
10713 */
10714 Tcl_CreateCommand(interp,"source",Et_Source,0,0);
10715
10716
10717 /* Define the variable Et_Interp to hold the interpreter.
10718 ** Not sure if this is ever used.
10719 */
10720 Et_Interp = interp;
10721
10722 /* Not sure if these variables are used. Need to
10723 ** research.
10724 */
10725 Tcl_SetVar(interp,"tcl_library",ET_TCL_LIBRARY,TCL_GLOBAL_ONLY);
10726 Tcl_SetVar(interp,"tcl_libPath",ET_TCL_LIBRARY,TCL_GLOBAL_ONLY);
10727 Tcl_SetVar2(interp,"env","TCL_LIBRARY",ET_TCL_LIBRARY,TCL_GLOBAL_ONLY);
10728
10729
10730 /* Not sure if these variables are used. Need to research.
10731 */
10732 Tcl_SetVar(interp,"tk_library",ET_TK_LIBRARY,TCL_GLOBAL_ONLY);
10733 Tcl_SetVar2(interp,"env","TK_LIBRARY",ET_TK_LIBRARY,TCL_GLOBAL_ONLY);
10734
10735 /* Not sure of the purpose of this line. Need to research.
10736 */
10737 Tcl_Eval(interp,zBgerror);
10738
10739
10740 /* Not sure of the purpose of this line. Need to research.
10741 */
10742 Et_GlobalEvalF(interp,"set dir $tcl_library;source $dir/tclIndex;unset dir");
10743
10744 /* Unsure of function of following lines. Need to research.
10745 */
10746 Tcl_LinkVar(interp,"Et_EvalTrace",(char*)&Et_EvalTrace,TCL_LINK_BOOLEAN);
10747 Tcl_SetVar(interp,"et_version",ET_VERSION,TCL_GLOBAL_ONLY);
10748
10749 return TCL_OK;
10750
10751 /* Put in a dummy goto, just to keep the compiler happy. Might want to keep
10752 ** the code below, just in case.
10753 */
10754 goto initerr;
10755
10756 initerr:
10757 Et_EvalF(interp,"Et_Bgerror \"%q\"", Tcl_GetStringResult(interp));
10758 return TCL_ERROR;
10759 }
10760
10761
10762 #if ET_EXTENSION
10763 /*
10764 ** If the -extension flag is used, then generate code that will be
10765 ** turned into a loadable shared library or DLL, not a standalone
10766 ** executable.
10767 */
10768 int ET_EXTENSION_NAME(Tcl_Interp *interp){
10769 int i;
10770 #ifndef ET_HAVE_INSERTPROC
10771 Tcl_AppendResult(interp,
10772 "mktclapp can only generate extensions for Tcl/Tk version "
10773 "8.0.3 and later. This is version "
10774 TCL_MAJOR_VERSION "." TCL_MINOR_VERSION "." TCL_RELEASE_SERIAL, 0);
10775 return TCL_ERROR;
10776 #endif
10777 #ifdef ET_HAVE_INSERTPROC
10778 #ifdef USE_TCL_STUBS
10779 if( Tcl_InitStubs(interp,"8.0",0)==0 ){
10780 return TCL_ERROR;
10781 }
10782 if( Tk_InitStubs(interp,"8.0",0)==0 ){
10783 return TCL_ERROR;
10784 }
10785 #endif
10786 Et_Interp = interp;
10787 TclStatInsertProc(Et_FileStat);
10788 TclAccessInsertProc(Et_FileAccess);
10789 TclOpenFileChannelInsertProc(Et_FileOpen);
10790 FilenameHashInit();
10791 for(i=0; i<sizeof(Et_CmdSet)/sizeof(Et_CmdSet[0]) - 1; i++){
10792 Tcl_CreateCommand(interp, Et_CmdSet[i].zName, Et_CmdSet[i].xProc, 0, 0);
10793 }
10794 #if ET_ENABLE_OBJ
10795 for(i=0; i<sizeof(Et_ObjSet)/sizeof(Et_ObjSet[0]) - 1; i++){
10796 Tcl_CreateObjCommand(interp, Et_ObjSet[i].zName, Et_ObjSet[i].xProc, 0, 0);
10797 }
10798 #endif
10799 Tcl_LinkVar(interp,"Et_EvalTrace",(char*)&Et_EvalTrace,TCL_LINK_BOOLEAN);
10800 Tcl_SetVar(interp,"et_version",ET_VERSION,TCL_GLOBAL_ONLY);
10801 #if ET_HAVE_APPINIT
10802 if( Et_AppInit(interp) == TCL_ERROR ){
10803 return TCL_ERROR;
10804 }
10805 #endif
10806 #ifdef ET_MAIN_SCRIPT
10807 if( Et_EvalF(interp,"source \"%q\"", ET_MAIN_SCRIPT)!=TCL_OK ){
10808 return TCL_ERROR;
10809 }
10810 #endif
10811 return TCL_OK;
10812 #endif /* ET_HAVE_INSERTPROC */
10813 }
10814 int ET_SAFE_EXTENSION_NAME(Tcl_Interp *interp){
10815 return ET_EXTENSION_NAME(interp);
10816 }
10817 #endif
10818
10819
10820 /*
10821 * $Log: appinit.c,v $
10822 * Revision 1.6 2002/04/23 06:26:42 dtashley
10823 * Minor changes in release year, name (to ESRG).
10824 *
10825 * Revision 1.5 2001/08/18 18:33:13 dtashley
10826 * Preparing for release of v1.05.
10827 *
10828 * Revision 1.4 2001/06/20 20:42:28 dtashley
10829 * Final changes before release of v1.04.
10830 *
10831 * Revision 1.3 2001/06/20 03:32:56 dtashley
10832 * Modifications for version 1.04.
10833 *
10834 * Revision 1.2 2001/06/20 02:56:04 dtashley
10835 * Conversion from binary mode to work under CVS.
10836 *
10837 * $History: appinit.c $
10838 *
10839 * ***************** Version 2 *****************
10840 * User: Dtashley Date: 1/03/01 Time: 2:03a
10841 * Updated in $/IjuScripter, IjuConsole/Source/Tk Base
10842 * Check-in in preparation for release of v1.03. Extraneous and redundant
10843 * calls removed.
10844 *
10845 * ***************** Version 1 *****************
10846 * User: Dtashley Date: 1/02/01 Time: 2:18a
10847 * Created in $/IjuScripter, IjuConsole/Source/Tk Base
10848 * Initial check-in.
10849 */
10850
10851 /* End of APPINIT.C */

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25