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