1 |
dashley |
25 |
/* $Header: /cvsroot/esrg/sfesrg/esrgpcpj/shared/tk_base/appinit.c,v 1.6 2002/04/23 06:26:42 dtashley Exp $ */
|
2 |
|
|
|
3 |
|
|
#define MODULE_APPINIT
|
4 |
|
|
|
5 |
|
|
#include <tcl.h>
|
6 |
|
|
|
7 |
|
|
#include "appinit.h"
|
8 |
|
|
#include "build_config.h"
|
9 |
|
|
#include "extninit.h"
|
10 |
|
|
#include "msgstrs.h"
|
11 |
|
|
|
12 |
|
|
|
13 |
|
|
#define INTERFACE 1
|
14 |
|
|
#if INTERFACE
|
15 |
|
|
#define ET_TCLARGS ClientData clientData,Tcl_Interp*interp,int argc,char**argv
|
16 |
|
|
#define ET_OBJARGS ClientData clientData,Tcl_Interp*interp,int objc,Tcl_Obj*CONST objv[]
|
17 |
|
|
#endif
|
18 |
|
|
#define ET_ENABLE_OBJ 0
|
19 |
|
|
#define ET_ENABLE_TK 1
|
20 |
|
|
#define ET_AUTO_FORK 0
|
21 |
|
|
#define ET_STANDALONE 0
|
22 |
|
|
#define ET_N_BUILTIN_SCRIPT 31
|
23 |
|
|
#define ET_VERSION "3.10"
|
24 |
|
|
#define ET_HAVE_APPINIT 0
|
25 |
|
|
#define ET_HAVE_PREINIT 0
|
26 |
|
|
#define ET_HAVE_MAIN 1
|
27 |
|
|
#define ET_HAVE_CUSTOM_MAINLOOP 0
|
28 |
|
|
#define ET_EXTENSION 0
|
29 |
|
|
#define ET_SHROUD_KEY 0
|
30 |
|
|
#define ET_READ_STDIN 0
|
31 |
|
|
#define ET_CONSOLE 1
|
32 |
|
|
static struct {
|
33 |
|
|
char *zName;
|
34 |
|
|
int (*xProc)(ET_TCLARGS);
|
35 |
|
|
} Et_CmdSet[] = {
|
36 |
|
|
{0, 0}};
|
37 |
|
|
static char Et_zFile0[] =
|
38 |
|
|
"proc auto_reset {} {\n"
|
39 |
|
|
"global auto_execs auto_index auto_oldpath\n"
|
40 |
|
|
"foreach p [info procs] {\n"
|
41 |
|
|
"if {[info exists auto_index($p)] && ![string match auto_* $p]\n"
|
42 |
|
|
"&& ([lsearch -exact {unknown pkg_mkIndex tclPkgSetup\n"
|
43 |
|
|
"tcl_findLibrary pkg_compareExtension\n"
|
44 |
|
|
"tclMacPkgSearch tclPkgUnknown} $p] < 0)} {\n"
|
45 |
|
|
"rename $p {}\n"
|
46 |
|
|
"}\n"
|
47 |
|
|
"}\n"
|
48 |
|
|
"catch {unset auto_execs}\n"
|
49 |
|
|
"catch {unset auto_index}\n"
|
50 |
|
|
"catch {unset auto_oldpath}\n"
|
51 |
|
|
"}\n"
|
52 |
|
|
"proc tcl_findLibrary {basename version patch initScript enVarName varName} {\n"
|
53 |
|
|
"upvar #0 $varName the_library\n"
|
54 |
|
|
"global env errorInfo\n"
|
55 |
|
|
"set dirs {}\n"
|
56 |
|
|
"set errors {}\n"
|
57 |
|
|
"if {[info exist the_library] && [string compare $the_library {}]} {\n"
|
58 |
|
|
"lappend dirs $the_library\n"
|
59 |
|
|
"} else {\n"
|
60 |
|
|
"if {[info exists env($enVarName)]} {\n"
|
61 |
|
|
"lappend dirs $env($enVarName)\n"
|
62 |
|
|
"}\n"
|
63 |
|
|
"lappend dirs [file join [file dirname [info library]] \\\n"
|
64 |
|
|
"\011\011$basename$version]\n"
|
65 |
|
|
"set parentDir [file dirname [file dirname [info nameofexecutable]]]\n"
|
66 |
|
|
"set grandParentDir [file dirname $parentDir]\n"
|
67 |
|
|
"lappend dirs [file join $parentDir lib $basename$version]\n"
|
68 |
|
|
"lappend dirs [file join $grandParentDir lib $basename$version]\n"
|
69 |
|
|
"lappend dirs [file join $parentDir library]\n"
|
70 |
|
|
"lappend dirs [file join $grandParentDir library]\n"
|
71 |
|
|
"if {![regexp {.*[ab][0-9]*} $patch ver]} {\n"
|
72 |
|
|
"set ver $version\n"
|
73 |
|
|
"}\n"
|
74 |
|
|
"lappend dirs [file join $grandParentDir $basename$ver library]\n"
|
75 |
|
|
"lappend dirs [file join [file dirname $grandParentDir] $basename$ver library]\n"
|
76 |
|
|
"}\n"
|
77 |
|
|
"foreach i $dirs {\n"
|
78 |
|
|
"set the_library $i\n"
|
79 |
|
|
"set file [file join $i $initScript]\n"
|
80 |
|
|
"if {[interp issafe] || [file exists $file]} {\n"
|
81 |
|
|
"if {![catch {uplevel #0 [list source $file]} msg]} {\n"
|
82 |
|
|
"return\n"
|
83 |
|
|
"} else {\n"
|
84 |
|
|
"append errors \"$file: $msg\\n$errorInfo\\n\"\n"
|
85 |
|
|
"}\n"
|
86 |
|
|
"}\n"
|
87 |
|
|
"}\n"
|
88 |
|
|
"set msg \"Can't find a usable $initScript in the following directories: \\n\"\n"
|
89 |
|
|
"append msg \" $dirs\\n\\n\"\n"
|
90 |
|
|
"append msg \"$errors\\n\\n\"\n"
|
91 |
|
|
"append msg \"This probably means that $basename wasn't installed properly.\\n\"\n"
|
92 |
|
|
"error $msg\n"
|
93 |
|
|
"}\n"
|
94 |
|
|
"if {[interp issafe]} {\n"
|
95 |
|
|
"return\011;# Stop sourcing the file here\n"
|
96 |
|
|
"}\n"
|
97 |
|
|
"proc auto_mkindex {dir args} {\n"
|
98 |
|
|
"global errorCode errorInfo\n"
|
99 |
|
|
"if {[interp issafe]} {\n"
|
100 |
|
|
"error \"can't generate index within safe interpreter\"\n"
|
101 |
|
|
"}\n"
|
102 |
|
|
"set oldDir [pwd]\n"
|
103 |
|
|
"cd $dir\n"
|
104 |
|
|
"set dir [pwd]\n"
|
105 |
|
|
"append index \"# Tcl autoload index file, version 2.0\\n\"\n"
|
106 |
|
|
"append index \"# This file is generated by the \\\"auto_mkindex\\\" command\\n\"\n"
|
107 |
|
|
"append index \"# and sourced to set up indexing information for one or\\n\"\n"
|
108 |
|
|
"append index \"# more commands. Typically each line is a command that\\n\"\n"
|
109 |
|
|
"append index \"# sets an element in the auto_index array, where the\\n\"\n"
|
110 |
|
|
"append index \"# element name is the name of a command and the value is\\n\"\n"
|
111 |
|
|
"append index \"# a script that loads the command.\\n\\n\"\n"
|
112 |
|
|
"if {$args == \"\"} {\n"
|
113 |
|
|
"set args *.tcl\n"
|
114 |
|
|
"}\n"
|
115 |
|
|
"auto_mkindex_parser::init\n"
|
116 |
|
|
"foreach file [eval glob $args] {\n"
|
117 |
|
|
"if {[catch {auto_mkindex_parser::mkindex $file} msg] == 0} {\n"
|
118 |
|
|
"append index $msg\n"
|
119 |
|
|
"} else {\n"
|
120 |
|
|
"set code $errorCode\n"
|
121 |
|
|
"set info $errorInfo\n"
|
122 |
|
|
"cd $oldDir\n"
|
123 |
|
|
"error $msg $info $code\n"
|
124 |
|
|
"}\n"
|
125 |
|
|
"}\n"
|
126 |
|
|
"auto_mkindex_parser::cleanup\n"
|
127 |
|
|
"set fid [open \"tclIndex\" w]\n"
|
128 |
|
|
"puts -nonewline $fid $index\n"
|
129 |
|
|
"close $fid\n"
|
130 |
|
|
"cd $oldDir\n"
|
131 |
|
|
"}\n"
|
132 |
|
|
"proc auto_mkindex_old {dir args} {\n"
|
133 |
|
|
"global errorCode errorInfo\n"
|
134 |
|
|
"set oldDir [pwd]\n"
|
135 |
|
|
"cd $dir\n"
|
136 |
|
|
"set dir [pwd]\n"
|
137 |
|
|
"append index \"# Tcl autoload index file, version 2.0\\n\"\n"
|
138 |
|
|
"append index \"# This file is generated by the \\\"auto_mkindex\\\" command\\n\"\n"
|
139 |
|
|
"append index \"# and sourced to set up indexing information for one or\\n\"\n"
|
140 |
|
|
"append index \"# more commands. Typically each line is a command that\\n\"\n"
|
141 |
|
|
"append index \"# sets an element in the auto_index array, where the\\n\"\n"
|
142 |
|
|
"append index \"# element name is the name of a command and the value is\\n\"\n"
|
143 |
|
|
"append index \"# a script that loads the command.\\n\\n\"\n"
|
144 |
|
|
"if {[string equal $args \"\"]} {\n"
|
145 |
|
|
"set args *.tcl\n"
|
146 |
|
|
"}\n"
|
147 |
|
|
"foreach file [eval glob $args] {\n"
|
148 |
|
|
"set f \"\"\n"
|
149 |
|
|
"set error [catch {\n"
|
150 |
|
|
"set f [open $file]\n"
|
151 |
|
|
"while {[gets $f line] >= 0} {\n"
|
152 |
|
|
"if {[regexp {^proc[ \011]+([^ \011]*)} $line match procName]} {\n"
|
153 |
|
|
"set procName [lindex [auto_qualify $procName \"::\"] 0]\n"
|
154 |
|
|
"append index \"set [list auto_index($procName)]\"\n"
|
155 |
|
|
"append index \" \\[list source \\[file join \\$dir [list $file]\\]\\]\\n\"\n"
|
156 |
|
|
"}\n"
|
157 |
|
|
"}\n"
|
158 |
|
|
"close $f\n"
|
159 |
|
|
"} msg]\n"
|
160 |
|
|
"if {$error} {\n"
|
161 |
|
|
"set code $errorCode\n"
|
162 |
|
|
"set info $errorInfo\n"
|
163 |
|
|
"catch {close $f}\n"
|
164 |
|
|
"cd $oldDir\n"
|
165 |
|
|
"error $msg $info $code\n"
|
166 |
|
|
"}\n"
|
167 |
|
|
"}\n"
|
168 |
|
|
"set f \"\"\n"
|
169 |
|
|
"set error [catch {\n"
|
170 |
|
|
"set f [open tclIndex w]\n"
|
171 |
|
|
"puts -nonewline $f $index\n"
|
172 |
|
|
"close $f\n"
|
173 |
|
|
"cd $oldDir\n"
|
174 |
|
|
"} msg]\n"
|
175 |
|
|
"if {$error} {\n"
|
176 |
|
|
"set code $errorCode\n"
|
177 |
|
|
"set info $errorInfo\n"
|
178 |
|
|
"catch {close $f}\n"
|
179 |
|
|
"cd $oldDir\n"
|
180 |
|
|
"error $msg $info $code\n"
|
181 |
|
|
"}\n"
|
182 |
|
|
"}\n"
|
183 |
|
|
"namespace eval auto_mkindex_parser {\n"
|
184 |
|
|
"variable parser \"\" ;# parser used to build index\n"
|
185 |
|
|
"variable index \"\" ;# maintains index as it is built\n"
|
186 |
|
|
"variable scriptFile \"\" ;# name of file being processed\n"
|
187 |
|
|
"variable contextStack \"\" ;# stack of namespace scopes\n"
|
188 |
|
|
"variable imports \"\" ;# keeps track of all imported cmds\n"
|
189 |
|
|
"variable initCommands \"\" ;# list of commands that create aliases\n"
|
190 |
|
|
"proc init {} {\n"
|
191 |
|
|
"variable parser\n"
|
192 |
|
|
"variable initCommands\n"
|
193 |
|
|
"if {![interp issafe]} {\n"
|
194 |
|
|
"set parser [interp create -safe]\n"
|
195 |
|
|
"$parser hide info\n"
|
196 |
|
|
"$parser hide rename\n"
|
197 |
|
|
"$parser hide proc\n"
|
198 |
|
|
"$parser hide namespace\n"
|
199 |
|
|
"$parser hide eval\n"
|
200 |
|
|
"$parser hide puts\n"
|
201 |
|
|
"$parser invokehidden namespace delete ::\n"
|
202 |
|
|
"$parser invokehidden proc unknown {args} {}\n"
|
203 |
|
|
"$parser expose namespace\n"
|
204 |
|
|
"$parser invokehidden rename namespace _%@namespace\n"
|
205 |
|
|
"$parser expose eval\n"
|
206 |
|
|
"$parser invokehidden rename eval _%@eval\n"
|
207 |
|
|
"foreach cmd $initCommands {\n"
|
208 |
|
|
"eval $cmd\n"
|
209 |
|
|
"}\n"
|
210 |
|
|
"}\n"
|
211 |
|
|
"}\n"
|
212 |
|
|
"proc cleanup {} {\n"
|
213 |
|
|
"variable parser\n"
|
214 |
|
|
"interp delete $parser\n"
|
215 |
|
|
"unset parser\n"
|
216 |
|
|
"}\n"
|
217 |
|
|
"}\n"
|
218 |
|
|
"proc auto_mkindex_parser::mkindex {file} {\n"
|
219 |
|
|
"variable parser\n"
|
220 |
|
|
"variable index\n"
|
221 |
|
|
"variable scriptFile\n"
|
222 |
|
|
"variable contextStack\n"
|
223 |
|
|
"variable imports\n"
|
224 |
|
|
"set scriptFile $file\n"
|
225 |
|
|
"set fid [open $file]\n"
|
226 |
|
|
"set contents [read $fid]\n"
|
227 |
|
|
"close $fid\n"
|
228 |
|
|
"regsub -all {\\$} $contents \"\\0\" contents\n"
|
229 |
|
|
"set index \"\"\n"
|
230 |
|
|
"set contextStack \"\"\n"
|
231 |
|
|
"set imports \"\"\n"
|
232 |
|
|
"$parser eval $contents\n"
|
233 |
|
|
"foreach name $imports {\n"
|
234 |
|
|
"catch {$parser eval [list _%@namespace forget $name]}\n"
|
235 |
|
|
"}\n"
|
236 |
|
|
"return $index\n"
|
237 |
|
|
"}\n"
|
238 |
|
|
"proc auto_mkindex_parser::hook {cmd} {\n"
|
239 |
|
|
"variable initCommands\n"
|
240 |
|
|
"lappend initCommands $cmd\n"
|
241 |
|
|
"}\n"
|
242 |
|
|
"proc auto_mkindex_parser::slavehook {cmd} {\n"
|
243 |
|
|
"variable initCommands\n"
|
244 |
|
|
"lappend initCommands \"\\$parser eval [list $cmd]\"\n"
|
245 |
|
|
"}\n"
|
246 |
|
|
"proc auto_mkindex_parser::command {name arglist body} {\n"
|
247 |
|
|
"hook [list auto_mkindex_parser::commandInit $name $arglist $body]\n"
|
248 |
|
|
"}\n"
|
249 |
|
|
"proc auto_mkindex_parser::commandInit {name arglist body} {\n"
|
250 |
|
|
"variable parser\n"
|
251 |
|
|
"set ns [namespace qualifiers $name]\n"
|
252 |
|
|
"set tail [namespace tail $name]\n"
|
253 |
|
|
"if {[string equal $ns \"\"]} {\n"
|
254 |
|
|
"set fakeName \"[namespace current]::_%@fake_$tail\"\n"
|
255 |
|
|
"} else {\n"
|
256 |
|
|
"set fakeName \"_%@fake_$name\"\n"
|
257 |
|
|
"regsub -all {::} $fakeName \"_\" fakeName\n"
|
258 |
|
|
"set fakeName \"[namespace current]::$fakeName\"\n"
|
259 |
|
|
"}\n"
|
260 |
|
|
"proc $fakeName $arglist $body\n"
|
261 |
|
|
"if {[regexp {::} $name]} {\n"
|
262 |
|
|
"set exportCmd [list _%@namespace export [namespace tail $name]]\n"
|
263 |
|
|
"$parser eval [list _%@namespace eval $ns $exportCmd]\n"
|
264 |
|
|
"set alias [namespace tail $fakeName]\n"
|
265 |
|
|
"$parser invokehidden proc $name {args} \"_%@eval {$alias} \\$args\"\n"
|
266 |
|
|
"$parser alias $alias $fakeName\n"
|
267 |
|
|
"} else {\n"
|
268 |
|
|
"$parser alias $name $fakeName\n"
|
269 |
|
|
"}\n"
|
270 |
|
|
"return\n"
|
271 |
|
|
"}\n"
|
272 |
|
|
"proc auto_mkindex_parser::fullname {name} {\n"
|
273 |
|
|
"variable contextStack\n"
|
274 |
|
|
"if {![string match ::* $name]} {\n"
|
275 |
|
|
"foreach ns $contextStack {\n"
|
276 |
|
|
"set name \"${ns}::$name\"\n"
|
277 |
|
|
"if {[string match ::* $name]} {\n"
|
278 |
|
|
"break\n"
|
279 |
|
|
"}\n"
|
280 |
|
|
"}\n"
|
281 |
|
|
"}\n"
|
282 |
|
|
"if {[string equal [namespace qualifiers $name] \"\"]} {\n"
|
283 |
|
|
"set name [namespace tail $name]\n"
|
284 |
|
|
"} elseif {![string match ::* $name]} {\n"
|
285 |
|
|
"set name \"::$name\"\n"
|
286 |
|
|
"}\n"
|
287 |
|
|
"regsub -all \"\\0\" $name \"\\$\" name\n"
|
288 |
|
|
"return $name\n"
|
289 |
|
|
"}\n"
|
290 |
|
|
"auto_mkindex_parser::command proc {name args} {\n"
|
291 |
|
|
"variable index\n"
|
292 |
|
|
"variable scriptFile\n"
|
293 |
|
|
"append index [list set auto_index([fullname $name])] \\\n"
|
294 |
|
|
"\011 [format { [list source [file join $dir %s]]} \\\n"
|
295 |
|
|
"\011 [file split $scriptFile]] \"\\n\"\n"
|
296 |
|
|
"}\n"
|
297 |
|
|
"auto_mkindex_parser::hook {\n"
|
298 |
|
|
"if {![catch {package require tbcload}]} {\n"
|
299 |
|
|
"if {[llength [info commands tbcload::bcproc]] == 0} {\n"
|
300 |
|
|
"auto_load tbcload::bcproc\n"
|
301 |
|
|
"}\n"
|
302 |
|
|
"load {} tbcload $auto_mkindex_parser::parser\n"
|
303 |
|
|
"auto_mkindex_parser::commandInit tbcload::bcproc {name args} {\n"
|
304 |
|
|
"variable index\n"
|
305 |
|
|
"variable scriptFile\n"
|
306 |
|
|
"append index [list set auto_index([fullname $name])] \\\n"
|
307 |
|
|
"\011\011 [format { [list source [file join $dir %s]]} \\\n"
|
308 |
|
|
"\011\011 [file split $scriptFile]] \"\\n\"\n"
|
309 |
|
|
"}\n"
|
310 |
|
|
"}\n"
|
311 |
|
|
"}\n"
|
312 |
|
|
"auto_mkindex_parser::command namespace {op args} {\n"
|
313 |
|
|
"switch -- $op {\n"
|
314 |
|
|
"eval {\n"
|
315 |
|
|
"variable parser\n"
|
316 |
|
|
"variable contextStack\n"
|
317 |
|
|
"set name [lindex $args 0]\n"
|
318 |
|
|
"set args [lrange $args 1 end]\n"
|
319 |
|
|
"set contextStack [linsert $contextStack 0 $name]\n"
|
320 |
|
|
"$parser eval [list _%@namespace eval $name] $args\n"
|
321 |
|
|
"set contextStack [lrange $contextStack 1 end]\n"
|
322 |
|
|
"}\n"
|
323 |
|
|
"import {\n"
|
324 |
|
|
"variable parser\n"
|
325 |
|
|
"variable imports\n"
|
326 |
|
|
"foreach pattern $args {\n"
|
327 |
|
|
"if {[string compare $pattern \"-force\"]} {\n"
|
328 |
|
|
"lappend imports $pattern\n"
|
329 |
|
|
"}\n"
|
330 |
|
|
"}\n"
|
331 |
|
|
"catch {$parser eval \"_%@namespace import $args\"}\n"
|
332 |
|
|
"}\n"
|
333 |
|
|
"}\n"
|
334 |
|
|
"}\n"
|
335 |
|
|
"return\n"
|
336 |
|
|
;
|
337 |
|
|
static char Et_zFile1[] =
|
338 |
|
|
"namespace eval tcl {\n"
|
339 |
|
|
"variable history\n"
|
340 |
|
|
"if {![info exists history]} {\n"
|
341 |
|
|
"array set history {\n"
|
342 |
|
|
"nextid\0110\n"
|
343 |
|
|
"keep\01120\n"
|
344 |
|
|
"oldest\011-20\n"
|
345 |
|
|
"}\n"
|
346 |
|
|
"}\n"
|
347 |
|
|
"}\n"
|
348 |
|
|
"proc history {args} {\n"
|
349 |
|
|
"set len [llength $args]\n"
|
350 |
|
|
"if {$len == 0} {\n"
|
351 |
|
|
"return [tcl::HistInfo]\n"
|
352 |
|
|
"}\n"
|
353 |
|
|
"set key [lindex $args 0]\n"
|
354 |
|
|
"set options \"add, change, clear, event, info, keep, nextid, or redo\"\n"
|
355 |
|
|
"switch -glob -- $key {\n"
|
356 |
|
|
"a* { # history add\n"
|
357 |
|
|
"if {$len > 3} {\n"
|
358 |
|
|
"return -code error \"wrong # args: should be \\\"history add event ?exec?\\\"\"\n"
|
359 |
|
|
"}\n"
|
360 |
|
|
"if {![string match $key* add]} {\n"
|
361 |
|
|
"return -code error \"bad option \\\"$key\\\": must be $options\"\n"
|
362 |
|
|
"}\n"
|
363 |
|
|
"if {$len == 3} {\n"
|
364 |
|
|
"set arg [lindex $args 2]\n"
|
365 |
|
|
"if {! ([string match e* $arg] && [string match $arg* exec])} {\n"
|
366 |
|
|
"return -code error \"bad argument \\\"$arg\\\": should be \\\"exec\\\"\"\n"
|
367 |
|
|
"}\n"
|
368 |
|
|
"}\n"
|
369 |
|
|
"return [tcl::HistAdd [lindex $args 1] [lindex $args 2]]\n"
|
370 |
|
|
"}\n"
|
371 |
|
|
"ch* { # history change\n"
|
372 |
|
|
"if {($len > 3) || ($len < 2)} {\n"
|
373 |
|
|
"return -code error \"wrong # args: should be \\\"history change newValue ?event?\\\"\"\n"
|
374 |
|
|
"}\n"
|
375 |
|
|
"if {![string match $key* change]} {\n"
|
376 |
|
|
"return -code error \"bad option \\\"$key\\\": must be $options\"\n"
|
377 |
|
|
"}\n"
|
378 |
|
|
"if {$len == 2} {\n"
|
379 |
|
|
"set event 0\n"
|
380 |
|
|
"} else {\n"
|
381 |
|
|
"set event [lindex $args 2]\n"
|
382 |
|
|
"}\n"
|
383 |
|
|
"return [tcl::HistChange [lindex $args 1] $event]\n"
|
384 |
|
|
"}\n"
|
385 |
|
|
"cl* { # history clear\n"
|
386 |
|
|
"if {($len > 1)} {\n"
|
387 |
|
|
"return -code error \"wrong # args: should be \\\"history clear\\\"\"\n"
|
388 |
|
|
"}\n"
|
389 |
|
|
"if {![string match $key* clear]} {\n"
|
390 |
|
|
"return -code error \"bad option \\\"$key\\\": must be $options\"\n"
|
391 |
|
|
"}\n"
|
392 |
|
|
"return [tcl::HistClear]\n"
|
393 |
|
|
"}\n"
|
394 |
|
|
"e* { # history event\n"
|
395 |
|
|
"if {$len > 2} {\n"
|
396 |
|
|
"return -code error \"wrong # args: should be \\\"history event ?event?\\\"\"\n"
|
397 |
|
|
"}\n"
|
398 |
|
|
"if {![string match $key* event]} {\n"
|
399 |
|
|
"return -code error \"bad option \\\"$key\\\": must be $options\"\n"
|
400 |
|
|
"}\n"
|
401 |
|
|
"if {$len == 1} {\n"
|
402 |
|
|
"set event -1\n"
|
403 |
|
|
"} else {\n"
|
404 |
|
|
"set event [lindex $args 1]\n"
|
405 |
|
|
"}\n"
|
406 |
|
|
"return [tcl::HistEvent $event]\n"
|
407 |
|
|
"}\n"
|
408 |
|
|
"i* { # history info\n"
|
409 |
|
|
"if {$len > 2} {\n"
|
410 |
|
|
"return -code error \"wrong # args: should be \\\"history info ?count?\\\"\"\n"
|
411 |
|
|
"}\n"
|
412 |
|
|
"if {![string match $key* info]} {\n"
|
413 |
|
|
"return -code error \"bad option \\\"$key\\\": must be $options\"\n"
|
414 |
|
|
"}\n"
|
415 |
|
|
"return [tcl::HistInfo [lindex $args 1]]\n"
|
416 |
|
|
"}\n"
|
417 |
|
|
"k* { # history keep\n"
|
418 |
|
|
"if {$len > 2} {\n"
|
419 |
|
|
"return -code error \"wrong # args: should be \\\"history keep ?count?\\\"\"\n"
|
420 |
|
|
"}\n"
|
421 |
|
|
"if {$len == 1} {\n"
|
422 |
|
|
"return [tcl::HistKeep]\n"
|
423 |
|
|
"} else {\n"
|
424 |
|
|
"set limit [lindex $args 1]\n"
|
425 |
|
|
"if {[catch {expr {~$limit}}] || ($limit < 0)} {\n"
|
426 |
|
|
"return -code error \"illegal keep count \\\"$limit\\\"\"\n"
|
427 |
|
|
"}\n"
|
428 |
|
|
"return [tcl::HistKeep $limit]\n"
|
429 |
|
|
"}\n"
|
430 |
|
|
"}\n"
|
431 |
|
|
"n* { # history nextid\n"
|
432 |
|
|
"if {$len > 1} {\n"
|
433 |
|
|
"return -code error \"wrong # args: should be \\\"history nextid\\\"\"\n"
|
434 |
|
|
"}\n"
|
435 |
|
|
"if {![string match $key* nextid]} {\n"
|
436 |
|
|
"return -code error \"bad option \\\"$key\\\": must be $options\"\n"
|
437 |
|
|
"}\n"
|
438 |
|
|
"return [expr {$tcl::history(nextid) + 1}]\n"
|
439 |
|
|
"}\n"
|
440 |
|
|
"r* { # history redo\n"
|
441 |
|
|
"if {$len > 2} {\n"
|
442 |
|
|
"return -code error \"wrong # args: should be \\\"history redo ?event?\\\"\"\n"
|
443 |
|
|
"}\n"
|
444 |
|
|
"if {![string match $key* redo]} {\n"
|
445 |
|
|
"return -code error \"bad option \\\"$key\\\": must be $options\"\n"
|
446 |
|
|
"}\n"
|
447 |
|
|
"return [tcl::HistRedo [lindex $args 1]]\n"
|
448 |
|
|
"}\n"
|
449 |
|
|
"default {\n"
|
450 |
|
|
"return -code error \"bad option \\\"$key\\\": must be $options\"\n"
|
451 |
|
|
"}\n"
|
452 |
|
|
"}\n"
|
453 |
|
|
"}\n"
|
454 |
|
|
"proc tcl::HistAdd {command {exec {}}} {\n"
|
455 |
|
|
"variable history\n"
|
456 |
|
|
"set i [incr history(nextid)]\n"
|
457 |
|
|
"set history($i) $command\n"
|
458 |
|
|
"set j [incr history(oldest)]\n"
|
459 |
|
|
"if {[info exists history($j)]} {unset history($j)}\n"
|
460 |
|
|
"if {[string match e* $exec]} {\n"
|
461 |
|
|
"return [uplevel #0 $command]\n"
|
462 |
|
|
"} else {\n"
|
463 |
|
|
"return {}\n"
|
464 |
|
|
"}\n"
|
465 |
|
|
"}\n"
|
466 |
|
|
"proc tcl::HistKeep {{limit {}}} {\n"
|
467 |
|
|
"variable history\n"
|
468 |
|
|
"if {[string length $limit] == 0} {\n"
|
469 |
|
|
"return $history(keep)\n"
|
470 |
|
|
"} else {\n"
|
471 |
|
|
"set oldold $history(oldest)\n"
|
472 |
|
|
"set history(oldest) [expr {$history(nextid) - $limit}]\n"
|
473 |
|
|
"for {} {$oldold <= $history(oldest)} {incr oldold} {\n"
|
474 |
|
|
"if {[info exists history($oldold)]} {unset history($oldold)}\n"
|
475 |
|
|
"}\n"
|
476 |
|
|
"set history(keep) $limit\n"
|
477 |
|
|
"}\n"
|
478 |
|
|
"}\n"
|
479 |
|
|
"proc tcl::HistClear {} {\n"
|
480 |
|
|
"variable history\n"
|
481 |
|
|
"set keep $history(keep)\n"
|
482 |
|
|
"unset history\n"
|
483 |
|
|
"array set history [list \\\n"
|
484 |
|
|
"\011nextid\0110\011\\\n"
|
485 |
|
|
"\011keep\011$keep\011\\\n"
|
486 |
|
|
"\011oldest\011-$keep\011\\\n"
|
487 |
|
|
" ]\n"
|
488 |
|
|
"}\n"
|
489 |
|
|
"proc tcl::HistInfo {{num {}}} {\n"
|
490 |
|
|
"variable history\n"
|
491 |
|
|
"if {$num == {}} {\n"
|
492 |
|
|
"set num [expr {$history(keep) + 1}]\n"
|
493 |
|
|
"}\n"
|
494 |
|
|
"set result {}\n"
|
495 |
|
|
"set newline \"\"\n"
|
496 |
|
|
"for {set i [expr {$history(nextid) - $num + 1}]} \\\n"
|
497 |
|
|
"\011 {$i <= $history(nextid)} {incr i} {\n"
|
498 |
|
|
"if {![info exists history($i)]} {\n"
|
499 |
|
|
"continue\n"
|
500 |
|
|
"}\n"
|
501 |
|
|
"set cmd [string trimright $history($i) \\ \\n]\n"
|
502 |
|
|
"regsub -all \\n $cmd \"\\n\\t\" cmd\n"
|
503 |
|
|
"append result $newline[format \"%6d %s\" $i $cmd]\n"
|
504 |
|
|
"set newline \\n\n"
|
505 |
|
|
"}\n"
|
506 |
|
|
"return $result\n"
|
507 |
|
|
"}\n"
|
508 |
|
|
"proc tcl::HistRedo {{event -1}} {\n"
|
509 |
|
|
"variable history\n"
|
510 |
|
|
"if {[string length $event] == 0} {\n"
|
511 |
|
|
"set event -1\n"
|
512 |
|
|
"}\n"
|
513 |
|
|
"set i [HistIndex $event]\n"
|
514 |
|
|
"if {$i == $history(nextid)} {\n"
|
515 |
|
|
"return -code error \"cannot redo the current event\"\n"
|
516 |
|
|
"}\n"
|
517 |
|
|
"set cmd $history($i)\n"
|
518 |
|
|
"HistChange $cmd 0\n"
|
519 |
|
|
"uplevel #0 $cmd\n"
|
520 |
|
|
"}\n"
|
521 |
|
|
"proc tcl::HistIndex {event} {\n"
|
522 |
|
|
"variable history\n"
|
523 |
|
|
"if {[catch {expr {~$event}}]} {\n"
|
524 |
|
|
"for {set i $history(nextid)} {[info exists history($i)]} {incr i -1} {\n"
|
525 |
|
|
"if {[string match $event* $history($i)]} {\n"
|
526 |
|
|
"return $i;\n"
|
527 |
|
|
"}\n"
|
528 |
|
|
"if {[string match $event $history($i)]} {\n"
|
529 |
|
|
"return $i;\n"
|
530 |
|
|
"}\n"
|
531 |
|
|
"}\n"
|
532 |
|
|
"return -code error \"no event matches \\\"$event\\\"\"\n"
|
533 |
|
|
"} elseif {$event <= 0} {\n"
|
534 |
|
|
"set i [expr {$history(nextid) + $event}]\n"
|
535 |
|
|
"} else {\n"
|
536 |
|
|
"set i $event\n"
|
537 |
|
|
"}\n"
|
538 |
|
|
"if {$i <= $history(oldest)} {\n"
|
539 |
|
|
"return -code error \"event \\\"$event\\\" is too far in the past\"\n"
|
540 |
|
|
"}\n"
|
541 |
|
|
"if {$i > $history(nextid)} {\n"
|
542 |
|
|
"return -code error \"event \\\"$event\\\" hasn't occured yet\"\n"
|
543 |
|
|
"}\n"
|
544 |
|
|
"return $i\n"
|
545 |
|
|
"}\n"
|
546 |
|
|
"proc tcl::HistEvent {event} {\n"
|
547 |
|
|
"variable history\n"
|
548 |
|
|
"set i [HistIndex $event]\n"
|
549 |
|
|
"if {[info exists history($i)]} {\n"
|
550 |
|
|
"return [string trimright $history($i) \\ \\n]\n"
|
551 |
|
|
"} else {\n"
|
552 |
|
|
"return \"\";\n"
|
553 |
|
|
"}\n"
|
554 |
|
|
"}\n"
|
555 |
|
|
"proc tcl::HistChange {cmd {event 0}} {\n"
|
556 |
|
|
"variable history\n"
|
557 |
|
|
"set i [HistIndex $event]\n"
|
558 |
|
|
"set history($i) $cmd\n"
|
559 |
|
|
"}\n"
|
560 |
|
|
;
|
561 |
|
|
static char Et_zFile2[] =
|
562 |
|
|
"if {[info commands package] == \"\"} {\n"
|
563 |
|
|
"error \"version mismatch: library\\nscripts expect Tcl version 7.5b1 or later but the loaded version is\\nonly [info patchlevel]\"\n"
|
564 |
|
|
"}\n"
|
565 |
|
|
"package require -exact Tcl 8.3\n"
|
566 |
|
|
"if {![info exists auto_path]} {\n"
|
567 |
|
|
"if {[info exist env(TCLLIBPATH)]} {\n"
|
568 |
|
|
"set auto_path $env(TCLLIBPATH)\n"
|
569 |
|
|
"} else {\n"
|
570 |
|
|
"set auto_path \"\"\n"
|
571 |
|
|
"}\n"
|
572 |
|
|
"}\n"
|
573 |
|
|
"if {[string compare [info library] {}]} {\n"
|
574 |
|
|
"foreach __dir [list [info library] [file dirname [info library]]] {\n"
|
575 |
|
|
"if {[lsearch -exact $auto_path $__dir] < 0} {\n"
|
576 |
|
|
"lappend auto_path $__dir\n"
|
577 |
|
|
"}\n"
|
578 |
|
|
"}\n"
|
579 |
|
|
"}\n"
|
580 |
|
|
"set __dir [file join [file dirname [file dirname \\\n"
|
581 |
|
|
"\011[info nameofexecutable]]] lib]\n"
|
582 |
|
|
"if {[lsearch -exact $auto_path $__dir] < 0} {\n"
|
583 |
|
|
"lappend auto_path $__dir\n"
|
584 |
|
|
"}\n"
|
585 |
|
|
"if {[info exist tcl_pkgPath]} {\n"
|
586 |
|
|
"foreach __dir $tcl_pkgPath {\n"
|
587 |
|
|
"if {[lsearch -exact $auto_path $__dir] < 0} {\n"
|
588 |
|
|
"lappend auto_path $__dir\n"
|
589 |
|
|
"}\n"
|
590 |
|
|
"}\n"
|
591 |
|
|
"}\n"
|
592 |
|
|
"if {[info exists __dir]} {\n"
|
593 |
|
|
"unset __dir\n"
|
594 |
|
|
"}\n"
|
595 |
|
|
"if {(![interp issafe]) && [string equal $tcl_platform(platform) \"windows\"]} {\n"
|
596 |
|
|
"namespace eval tcl {\n"
|
597 |
|
|
"proc envTraceProc {lo n1 n2 op} {\n"
|
598 |
|
|
"set x $::env($n2)\n"
|
599 |
|
|
"set ::env($lo) $x\n"
|
600 |
|
|
"set ::env([string toupper $lo]) $x\n"
|
601 |
|
|
"}\n"
|
602 |
|
|
"}\n"
|
603 |
|
|
"foreach p [array names env] {\n"
|
604 |
|
|
"set u [string toupper $p]\n"
|
605 |
|
|
"if {[string compare $u $p]} {\n"
|
606 |
|
|
"switch -- $u {\n"
|
607 |
|
|
"COMSPEC -\n"
|
608 |
|
|
"PATH {\n"
|
609 |
|
|
"if {![info exists env($u)]} {\n"
|
610 |
|
|
"set env($u) $env($p)\n"
|
611 |
|
|
"}\n"
|
612 |
|
|
"trace variable env($p) w [list tcl::envTraceProc $p]\n"
|
613 |
|
|
"trace variable env($u) w [list tcl::envTraceProc $p]\n"
|
614 |
|
|
"}\n"
|
615 |
|
|
"}\n"
|
616 |
|
|
"}\n"
|
617 |
|
|
"}\n"
|
618 |
|
|
"if {[info exists p]} {\n"
|
619 |
|
|
"unset p\n"
|
620 |
|
|
"}\n"
|
621 |
|
|
"if {[info exists u]} {\n"
|
622 |
|
|
"unset u\n"
|
623 |
|
|
"}\n"
|
624 |
|
|
"if {![info exists env(COMSPEC)]} {\n"
|
625 |
|
|
"if {[string equal $tcl_platform(os) \"Windows NT\"]} {\n"
|
626 |
|
|
"set env(COMSPEC) cmd.exe\n"
|
627 |
|
|
"} else {\n"
|
628 |
|
|
"set env(COMSPEC) command.com\n"
|
629 |
|
|
"}\n"
|
630 |
|
|
"}\n"
|
631 |
|
|
"}\n"
|
632 |
|
|
"package unknown tclPkgUnknown\n"
|
633 |
|
|
"if {[llength [info commands exec]] == 0} {\n"
|
634 |
|
|
"set auto_noexec 1\n"
|
635 |
|
|
"}\n"
|
636 |
|
|
"set errorCode \"\"\n"
|
637 |
|
|
"set errorInfo \"\"\n"
|
638 |
|
|
"if {[llength [info commands tclLog]] == 0} {\n"
|
639 |
|
|
"proc tclLog {string} {\n"
|
640 |
|
|
"catch {puts stderr $string}\n"
|
641 |
|
|
"}\n"
|
642 |
|
|
"}\n"
|
643 |
|
|
"proc unknown args {\n"
|
644 |
|
|
"global auto_noexec auto_noload env unknown_pending tcl_interactive\n"
|
645 |
|
|
"global errorCode errorInfo\n"
|
646 |
|
|
"set cmd [lindex $args 0]\n"
|
647 |
|
|
"if {[regexp \"^namespace\\[ \\t\\n\\]+inscope\" $cmd] && [llength $cmd] == 4} {\n"
|
648 |
|
|
"set arglist [lrange $args 1 end]\n"
|
649 |
|
|
"set ret [catch {uplevel $cmd $arglist} result]\n"
|
650 |
|
|
"if {$ret == 0} {\n"
|
651 |
|
|
"return $result\n"
|
652 |
|
|
"} else {\n"
|
653 |
|
|
"return -code $ret -errorcode $errorCode $result\n"
|
654 |
|
|
"}\n"
|
655 |
|
|
"}\n"
|
656 |
|
|
"set savedErrorCode $errorCode\n"
|
657 |
|
|
"set savedErrorInfo $errorInfo\n"
|
658 |
|
|
"set name [lindex $args 0]\n"
|
659 |
|
|
"if {![info exists auto_noload]} {\n"
|
660 |
|
|
"if {[info exists unknown_pending($name)]} {\n"
|
661 |
|
|
"return -code error \"self-referential recursion in \\\"unknown\\\" for command \\\"$name\\\"\";\n"
|
662 |
|
|
"}\n"
|
663 |
|
|
"set unknown_pending($name) pending;\n"
|
664 |
|
|
"set ret [catch {auto_load $name [uplevel 1 {namespace current}]} msg]\n"
|
665 |
|
|
"unset unknown_pending($name);\n"
|
666 |
|
|
"if {$ret != 0} {\n"
|
667 |
|
|
"append errorInfo \"\\n (autoloading \\\"$name\\\")\"\n"
|
668 |
|
|
"return -code $ret -errorcode $errorCode -errorinfo $errorInfo $msg\n"
|
669 |
|
|
"}\n"
|
670 |
|
|
"if {![array size unknown_pending]} {\n"
|
671 |
|
|
"unset unknown_pending\n"
|
672 |
|
|
"}\n"
|
673 |
|
|
"if {$msg} {\n"
|
674 |
|
|
"set errorCode $savedErrorCode\n"
|
675 |
|
|
"set errorInfo $savedErrorInfo\n"
|
676 |
|
|
"set code [catch {uplevel 1 $args} msg]\n"
|
677 |
|
|
"if {$code == 1} {\n"
|
678 |
|
|
"set new [split $errorInfo \\n]\n"
|
679 |
|
|
"set new [join [lrange $new 0 [expr {[llength $new] - 6}]] \\n]\n"
|
680 |
|
|
"return -code error -errorcode $errorCode \\\n"
|
681 |
|
|
"\011\011\011-errorinfo $new $msg\n"
|
682 |
|
|
"} else {\n"
|
683 |
|
|
"return -code $code $msg\n"
|
684 |
|
|
"}\n"
|
685 |
|
|
"}\n"
|
686 |
|
|
"}\n"
|
687 |
|
|
"if {([info level] == 1) && [string equal [info script] \"\"] \\\n"
|
688 |
|
|
"\011 && [info exists tcl_interactive] && $tcl_interactive} {\n"
|
689 |
|
|
"if {![info exists auto_noexec]} {\n"
|
690 |
|
|
"set new [auto_execok $name]\n"
|
691 |
|
|
"if {[string compare {} $new]} {\n"
|
692 |
|
|
"set errorCode $savedErrorCode\n"
|
693 |
|
|
"set errorInfo $savedErrorInfo\n"
|
694 |
|
|
"set redir \"\"\n"
|
695 |
|
|
"if {[string equal [info commands console] \"\"]} {\n"
|
696 |
|
|
"set redir \">&@stdout <@stdin\"\n"
|
697 |
|
|
"}\n"
|
698 |
|
|
"return [uplevel exec $redir $new [lrange $args 1 end]]\n"
|
699 |
|
|
"}\n"
|
700 |
|
|
"}\n"
|
701 |
|
|
"set errorCode $savedErrorCode\n"
|
702 |
|
|
"set errorInfo $savedErrorInfo\n"
|
703 |
|
|
"if {[string equal $name \"!!\"]} {\n"
|
704 |
|
|
"set newcmd [history event]\n"
|
705 |
|
|
"} elseif {[regexp {^!(.+)$} $name dummy event]} {\n"
|
706 |
|
|
"set newcmd [history event $event]\n"
|
707 |
|
|
"} elseif {[regexp {^\\^([^^]*)\\^([^^]*)\\^?$} $name dummy old new]} {\n"
|
708 |
|
|
"set newcmd [history event -1]\n"
|
709 |
|
|
"catch {regsub -all -- $old $newcmd $new newcmd}\n"
|
710 |
|
|
"}\n"
|
711 |
|
|
"if {[info exists newcmd]} {\n"
|
712 |
|
|
"tclLog $newcmd\n"
|
713 |
|
|
"history change $newcmd 0\n"
|
714 |
|
|
"return [uplevel $newcmd]\n"
|
715 |
|
|
"}\n"
|
716 |
|
|
"set ret [catch {set cmds [info commands $name*]} msg]\n"
|
717 |
|
|
"if {[string equal $name \"::\"]} {\n"
|
718 |
|
|
"set name \"\"\n"
|
719 |
|
|
"}\n"
|
720 |
|
|
"if {$ret != 0} {\n"
|
721 |
|
|
"return -code $ret -errorcode $errorCode \\\n"
|
722 |
|
|
"\011\011\"error in unknown while checking if \\\"$name\\\" is a unique command abbreviation: $msg\"\n"
|
723 |
|
|
"}\n"
|
724 |
|
|
"if {[llength $cmds] == 1} {\n"
|
725 |
|
|
"return [uplevel [lreplace $args 0 0 $cmds]]\n"
|
726 |
|
|
"}\n"
|
727 |
|
|
"if {[llength $cmds]} {\n"
|
728 |
|
|
"if {[string equal $name \"\"]} {\n"
|
729 |
|
|
"return -code error \"empty command name \\\"\\\"\"\n"
|
730 |
|
|
"} else {\n"
|
731 |
|
|
"return -code error \\\n"
|
732 |
|
|
"\011\011\011\"ambiguous command name \\\"$name\\\": [lsort $cmds]\"\n"
|
733 |
|
|
"}\n"
|
734 |
|
|
"}\n"
|
735 |
|
|
"}\n"
|
736 |
|
|
"return -code error \"invalid command name \\\"$name\\\"\"\n"
|
737 |
|
|
"}\n"
|
738 |
|
|
"proc auto_load {cmd {namespace {}}} {\n"
|
739 |
|
|
"global auto_index auto_oldpath auto_path\n"
|
740 |
|
|
"if {[string length $namespace] == 0} {\n"
|
741 |
|
|
"set namespace [uplevel {namespace current}]\n"
|
742 |
|
|
"}\n"
|
743 |
|
|
"set nameList [auto_qualify $cmd $namespace]\n"
|
744 |
|
|
"lappend nameList $cmd\n"
|
745 |
|
|
"foreach name $nameList {\n"
|
746 |
|
|
"if {[info exists auto_index($name)]} {\n"
|
747 |
|
|
"uplevel #0 $auto_index($name)\n"
|
748 |
|
|
"return [expr {[info commands $name] != \"\"}]\n"
|
749 |
|
|
"}\n"
|
750 |
|
|
"}\n"
|
751 |
|
|
"if {![info exists auto_path]} {\n"
|
752 |
|
|
"return 0\n"
|
753 |
|
|
"}\n"
|
754 |
|
|
"if {![auto_load_index]} {\n"
|
755 |
|
|
"return 0\n"
|
756 |
|
|
"}\n"
|
757 |
|
|
"foreach name $nameList {\n"
|
758 |
|
|
"if {[info exists auto_index($name)]} {\n"
|
759 |
|
|
"uplevel #0 $auto_index($name)\n"
|
760 |
|
|
"if { ![string equal [namespace which -command $name] \"\"] } {\n"
|
761 |
|
|
"return 1\n"
|
762 |
|
|
"}\n"
|
763 |
|
|
"}\n"
|
764 |
|
|
"}\n"
|
765 |
|
|
"return 0\n"
|
766 |
|
|
"}\n"
|
767 |
|
|
"proc auto_load_index {} {\n"
|
768 |
|
|
"global auto_index auto_oldpath auto_path errorInfo errorCode\n"
|
769 |
|
|
"if {[info exists auto_oldpath] && \\\n"
|
770 |
|
|
"\011 [string equal $auto_oldpath $auto_path]} {\n"
|
771 |
|
|
"return 0\n"
|
772 |
|
|
"}\n"
|
773 |
|
|
"set auto_oldpath $auto_path\n"
|
774 |
|
|
"set issafe [interp issafe]\n"
|
775 |
|
|
"for {set i [expr {[llength $auto_path] - 1}]} {$i >= 0} {incr i -1} {\n"
|
776 |
|
|
"set dir [lindex $auto_path $i]\n"
|
777 |
|
|
"set f \"\"\n"
|
778 |
|
|
"if {$issafe} {\n"
|
779 |
|
|
"catch {source [file join $dir tclIndex]}\n"
|
780 |
|
|
"} elseif {[catch {set f [open [file join $dir tclIndex]]}]} {\n"
|
781 |
|
|
"continue\n"
|
782 |
|
|
"} else {\n"
|
783 |
|
|
"set error [catch {\n"
|
784 |
|
|
"set id [gets $f]\n"
|
785 |
|
|
"if {[string equal $id \\\n"
|
786 |
|
|
"\011\011\011\"# Tcl autoload index file, version 2.0\"]} {\n"
|
787 |
|
|
"eval [read $f]\n"
|
788 |
|
|
"} elseif {[string equal $id \"# Tcl autoload index file: each line identifies a Tcl\"]} {\n"
|
789 |
|
|
"while {[gets $f line] >= 0} {\n"
|
790 |
|
|
"if {[string equal [string index $line 0] \"#\"] \\\n"
|
791 |
|
|
"\011\011\011\011|| ([llength $line] != 2)} {\n"
|
792 |
|
|
"continue\n"
|
793 |
|
|
"}\n"
|
794 |
|
|
"set name [lindex $line 0]\n"
|
795 |
|
|
"set auto_index($name) \\\n"
|
796 |
|
|
"\011\011\011\011\"source [file join $dir [lindex $line 1]]\"\n"
|
797 |
|
|
"}\n"
|
798 |
|
|
"} else {\n"
|
799 |
|
|
"error \"[file join $dir tclIndex] isn't a proper Tcl index file\"\n"
|
800 |
|
|
"}\n"
|
801 |
|
|
"} msg]\n"
|
802 |
|
|
"if {[string compare $f \"\"]} {\n"
|
803 |
|
|
"close $f\n"
|
804 |
|
|
"}\n"
|
805 |
|
|
"if {$error} {\n"
|
806 |
|
|
"error $msg $errorInfo $errorCode\n"
|
807 |
|
|
"}\n"
|
808 |
|
|
"}\n"
|
809 |
|
|
"}\n"
|
810 |
|
|
"return 1\n"
|
811 |
|
|
"}\n"
|
812 |
|
|
"proc auto_qualify {cmd namespace} {\n"
|
813 |
|
|
"set n [regsub -all {::+} $cmd :: cmd]\n"
|
814 |
|
|
"if {[regexp {^::(.*)$} $cmd x tail]} {\n"
|
815 |
|
|
"if {$n > 1} {\n"
|
816 |
|
|
"return [list $cmd]\n"
|
817 |
|
|
"} else {\n"
|
818 |
|
|
"return [list $tail]\n"
|
819 |
|
|
"}\n"
|
820 |
|
|
"}\n"
|
821 |
|
|
"if {$n == 0} {\n"
|
822 |
|
|
"if {[string equal $namespace ::]} {\n"
|
823 |
|
|
"return [list $cmd]\n"
|
824 |
|
|
"} else {\n"
|
825 |
|
|
"return [list ${namespace}::$cmd $cmd]\n"
|
826 |
|
|
"}\n"
|
827 |
|
|
"} elseif {[string equal $namespace ::]} {\n"
|
828 |
|
|
"return [list ::$cmd]\n"
|
829 |
|
|
"} else {\n"
|
830 |
|
|
"return [list ${namespace}::$cmd ::$cmd]\n"
|
831 |
|
|
"}\n"
|
832 |
|
|
"}\n"
|
833 |
|
|
"proc auto_import {pattern} {\n"
|
834 |
|
|
"global auto_index\n"
|
835 |
|
|
"set ns [uplevel namespace current]\n"
|
836 |
|
|
"set patternList [auto_qualify $pattern $ns]\n"
|
837 |
|
|
"auto_load_index\n"
|
838 |
|
|
"foreach pattern $patternList {\n"
|
839 |
|
|
"foreach name [array names auto_index] {\n"
|
840 |
|
|
"if {[string match $pattern $name] && \\\n"
|
841 |
|
|
"\011\011 [string equal \"\" [info commands $name]]} {\n"
|
842 |
|
|
"uplevel #0 $auto_index($name)\n"
|
843 |
|
|
"}\n"
|
844 |
|
|
"}\n"
|
845 |
|
|
"}\n"
|
846 |
|
|
"}\n"
|
847 |
|
|
"if {[string equal windows $tcl_platform(platform)]} {\n"
|
848 |
|
|
"proc auto_execok name {\n"
|
849 |
|
|
"global auto_execs env tcl_platform\n"
|
850 |
|
|
"if {[info exists auto_execs($name)]} {\n"
|
851 |
|
|
"return $auto_execs($name)\n"
|
852 |
|
|
"}\n"
|
853 |
|
|
"set auto_execs($name) \"\"\n"
|
854 |
|
|
"set shellBuiltins [list cls copy date del erase dir echo mkdir \\\n"
|
855 |
|
|
"\011 md rename ren rmdir rd time type ver vol]\n"
|
856 |
|
|
"if {[string equal $tcl_platform(os) \"Windows NT\"]} {\n"
|
857 |
|
|
"lappend shellBuiltins \"start\"\n"
|
858 |
|
|
"}\n"
|
859 |
|
|
"if {[lsearch -exact $shellBuiltins $name] != -1} {\n"
|
860 |
|
|
"return [set auto_execs($name) [list $env(COMSPEC) /c $name]]\n"
|
861 |
|
|
"}\n"
|
862 |
|
|
"if {[llength [file split $name]] != 1} {\n"
|
863 |
|
|
"foreach ext {{} .com .exe .bat} {\n"
|
864 |
|
|
"set file ${name}${ext}\n"
|
865 |
|
|
"if {[file exists $file] && ![file isdirectory $file]} {\n"
|
866 |
|
|
"return [set auto_execs($name) [list $file]]\n"
|
867 |
|
|
"}\n"
|
868 |
|
|
"}\n"
|
869 |
|
|
"return \"\"\n"
|
870 |
|
|
"}\n"
|
871 |
|
|
"set path \"[file dirname [info nameof]];.;\"\n"
|
872 |
|
|
"if {[info exists env(WINDIR)]} {\n"
|
873 |
|
|
"set windir $env(WINDIR) \n"
|
874 |
|
|
"}\n"
|
875 |
|
|
"if {[info exists windir]} {\n"
|
876 |
|
|
"if {[string equal $tcl_platform(os) \"Windows NT\"]} {\n"
|
877 |
|
|
"append path \"$windir/system32;\"\n"
|
878 |
|
|
"}\n"
|
879 |
|
|
"append path \"$windir/system;$windir;\"\n"
|
880 |
|
|
"}\n"
|
881 |
|
|
"foreach var {PATH Path path} {\n"
|
882 |
|
|
"if {[info exists env($var)]} {\n"
|
883 |
|
|
"append path \";$env($var)\"\n"
|
884 |
|
|
"}\n"
|
885 |
|
|
"}\n"
|
886 |
|
|
"foreach dir [split $path {;}] {\n"
|
887 |
|
|
"if {[info exists checked($dir)] || [string equal {} $dir]} { continue }\n"
|
888 |
|
|
"set checked($dir) {}\n"
|
889 |
|
|
"foreach ext {{} .com .exe .bat} {\n"
|
890 |
|
|
"set file [file join $dir ${name}${ext}]\n"
|
891 |
|
|
"if {[file exists $file] && ![file isdirectory $file]} {\n"
|
892 |
|
|
"return [set auto_execs($name) [list $file]]\n"
|
893 |
|
|
"}\n"
|
894 |
|
|
"}\n"
|
895 |
|
|
"}\n"
|
896 |
|
|
"return \"\"\n"
|
897 |
|
|
"}\n"
|
898 |
|
|
"} else {\n"
|
899 |
|
|
"proc auto_execok name {\n"
|
900 |
|
|
"global auto_execs env\n"
|
901 |
|
|
"if {[info exists auto_execs($name)]} {\n"
|
902 |
|
|
"return $auto_execs($name)\n"
|
903 |
|
|
"}\n"
|
904 |
|
|
"set auto_execs($name) \"\"\n"
|
905 |
|
|
"if {[llength [file split $name]] != 1} {\n"
|
906 |
|
|
"if {[file executable $name] && ![file isdirectory $name]} {\n"
|
907 |
|
|
"set auto_execs($name) [list $name]\n"
|
908 |
|
|
"}\n"
|
909 |
|
|
"return $auto_execs($name)\n"
|
910 |
|
|
"}\n"
|
911 |
|
|
"foreach dir [split $env(PATH) :] {\n"
|
912 |
|
|
"if {[string equal $dir \"\"]} {\n"
|
913 |
|
|
"set dir .\n"
|
914 |
|
|
"}\n"
|
915 |
|
|
"set file [file join $dir $name]\n"
|
916 |
|
|
"if {[file executable $file] && ![file isdirectory $file]} {\n"
|
917 |
|
|
"set auto_execs($name) [list $file]\n"
|
918 |
|
|
"return $auto_execs($name)\n"
|
919 |
|
|
"}\n"
|
920 |
|
|
"}\n"
|
921 |
|
|
"return \"\"\n"
|
922 |
|
|
"}\n"
|
923 |
|
|
"}\n"
|
924 |
|
|
;
|
925 |
|
|
static char Et_zFile3[] =
|
926 |
|
|
"namespace eval ::pkg {\n"
|
927 |
|
|
"}\n"
|
928 |
|
|
"proc pkg_compareExtension { fileName {ext {}} } {\n"
|
929 |
|
|
"global tcl_platform\n"
|
930 |
|
|
"if {[string length $ext] == 0} {\n"
|
931 |
|
|
"set ext [info sharedlibextension]\n"
|
932 |
|
|
"}\n"
|
933 |
|
|
"if {[string equal $tcl_platform(platform) \"windows\"]} {\n"
|
934 |
|
|
"return [string equal -nocase [file extension $fileName] $ext]\n"
|
935 |
|
|
"} else {\n"
|
936 |
|
|
"return [string equal [file extension $fileName] $ext]\n"
|
937 |
|
|
"}\n"
|
938 |
|
|
"}\n"
|
939 |
|
|
"proc pkg_mkIndex {args} {\n"
|
940 |
|
|
"global errorCode errorInfo\n"
|
941 |
|
|
"set usage {\"pkg_mkIndex ?-direct? ?-verbose? ?-load pattern? ?--? dir ?pattern ...?\"};\n"
|
942 |
|
|
"set argCount [llength $args]\n"
|
943 |
|
|
"if {$argCount < 1} {\n"
|
944 |
|
|
"return -code error \"wrong # args: should be\\n$usage\"\n"
|
945 |
|
|
"}\n"
|
946 |
|
|
"set more \"\"\n"
|
947 |
|
|
"set direct 1\n"
|
948 |
|
|
"set doVerbose 0\n"
|
949 |
|
|
"set loadPat \"\"\n"
|
950 |
|
|
"for {set idx 0} {$idx < $argCount} {incr idx} {\n"
|
951 |
|
|
"set flag [lindex $args $idx]\n"
|
952 |
|
|
"switch -glob -- $flag {\n"
|
953 |
|
|
"-- {\n"
|
954 |
|
|
"incr idx\n"
|
955 |
|
|
"break\n"
|
956 |
|
|
"}\n"
|
957 |
|
|
"-verbose {\n"
|
958 |
|
|
"set doVerbose 1\n"
|
959 |
|
|
"}\n"
|
960 |
|
|
"-lazy {\n"
|
961 |
|
|
"set direct 0\n"
|
962 |
|
|
"append more \" -lazy\"\n"
|
963 |
|
|
"}\n"
|
964 |
|
|
"-direct {\n"
|
965 |
|
|
"append more \" -direct\"\n"
|
966 |
|
|
"}\n"
|
967 |
|
|
"-load {\n"
|
968 |
|
|
"incr idx\n"
|
969 |
|
|
"set loadPat [lindex $args $idx]\n"
|
970 |
|
|
"append more \" -load $loadPat\"\n"
|
971 |
|
|
"}\n"
|
972 |
|
|
"-* {\n"
|
973 |
|
|
"return -code error \"unknown flag $flag: should be\\n$usage\"\n"
|
974 |
|
|
"}\n"
|
975 |
|
|
"default {\n"
|
976 |
|
|
"break\n"
|
977 |
|
|
"}\n"
|
978 |
|
|
"}\n"
|
979 |
|
|
"}\n"
|
980 |
|
|
"set dir [lindex $args $idx]\n"
|
981 |
|
|
"set patternList [lrange $args [expr {$idx + 1}] end]\n"
|
982 |
|
|
"if {[llength $patternList] == 0} {\n"
|
983 |
|
|
"set patternList [list \"*.tcl\" \"*[info sharedlibextension]\"]\n"
|
984 |
|
|
"}\n"
|
985 |
|
|
"set oldDir [pwd]\n"
|
986 |
|
|
"cd $dir\n"
|
987 |
|
|
"if {[catch {eval glob $patternList} fileList]} {\n"
|
988 |
|
|
"global errorCode errorInfo\n"
|
989 |
|
|
"cd $oldDir\n"
|
990 |
|
|
"return -code error -errorcode $errorCode -errorinfo $errorInfo $fileList\n"
|
991 |
|
|
"}\n"
|
992 |
|
|
"foreach file $fileList {\n"
|
993 |
|
|
"if {[string equal $file \"pkgIndex.tcl\"]} {\n"
|
994 |
|
|
"continue\n"
|
995 |
|
|
"}\n"
|
996 |
|
|
"cd $oldDir\n"
|
997 |
|
|
"set c [interp create]\n"
|
998 |
|
|
"foreach pkg [info loaded] {\n"
|
999 |
|
|
"if {! [string match $loadPat [lindex $pkg 1]]} {\n"
|
1000 |
|
|
"continue\n"
|
1001 |
|
|
"}\n"
|
1002 |
|
|
"if {[catch {\n"
|
1003 |
|
|
"load [lindex $pkg 0] [lindex $pkg 1] $c\n"
|
1004 |
|
|
"} err]} {\n"
|
1005 |
|
|
"if {$doVerbose} {\n"
|
1006 |
|
|
"tclLog \"warning: load [lindex $pkg 0] [lindex $pkg 1]\\nfailed with: $err\"\n"
|
1007 |
|
|
"}\n"
|
1008 |
|
|
"} elseif {$doVerbose} {\n"
|
1009 |
|
|
"tclLog \"loaded [lindex $pkg 0] [lindex $pkg 1]\"\n"
|
1010 |
|
|
"}\n"
|
1011 |
|
|
"if {[string equal [lindex $pkg 1] \"Tk\"]} {\n"
|
1012 |
|
|
"$c eval [list wm withdraw .]\n"
|
1013 |
|
|
"}\n"
|
1014 |
|
|
"}\n"
|
1015 |
|
|
"cd $dir\n"
|
1016 |
|
|
"$c eval {\n"
|
1017 |
|
|
"rename package __package_orig\n"
|
1018 |
|
|
"proc package {what args} {\n"
|
1019 |
|
|
"switch -- $what {\n"
|
1020 |
|
|
"require { return ; # ignore transitive requires }\n"
|
1021 |
|
|
"default { eval __package_orig {$what} $args }\n"
|
1022 |
|
|
"}\n"
|
1023 |
|
|
"}\n"
|
1024 |
|
|
"proc tclPkgUnknown args {}\n"
|
1025 |
|
|
"package unknown tclPkgUnknown\n"
|
1026 |
|
|
"proc unknown {args} {}\n"
|
1027 |
|
|
"proc auto_import {args} {}\n"
|
1028 |
|
|
"namespace eval ::tcl {\n"
|
1029 |
|
|
"variable file\011\011;# Current file being processed\n"
|
1030 |
|
|
"variable direct\011\011;# -direct flag value\n"
|
1031 |
|
|
"variable x\011\011;# Loop variable\n"
|
1032 |
|
|
"variable debug\011\011;# For debugging\n"
|
1033 |
|
|
"variable type\011\011;# \"load\" or \"source\", for -direct\n"
|
1034 |
|
|
"variable namespaces\011;# Existing namespaces (e.g., ::tcl)\n"
|
1035 |
|
|
"variable packages\011;# Existing packages (e.g., Tcl)\n"
|
1036 |
|
|
"variable origCmds\011;# Existing commands\n"
|
1037 |
|
|
"variable newCmds\011;# Newly created commands\n"
|
1038 |
|
|
"variable newPkgs {}\011;# Newly created packages\n"
|
1039 |
|
|
"}\n"
|
1040 |
|
|
"}\n"
|
1041 |
|
|
"$c eval [list set ::tcl::file $file]\n"
|
1042 |
|
|
"$c eval [list set ::tcl::direct $direct]\n"
|
1043 |
|
|
"foreach p {pkg_compareExtension} {\n"
|
1044 |
|
|
"$c eval [list proc $p [info args $p] [info body $p]]\n"
|
1045 |
|
|
"}\n"
|
1046 |
|
|
"if {[catch {\n"
|
1047 |
|
|
"$c eval {\n"
|
1048 |
|
|
"set ::tcl::debug \"loading or sourcing\"\n"
|
1049 |
|
|
"proc ::tcl::GetAllNamespaces {{root ::}} {\n"
|
1050 |
|
|
"set list $root\n"
|
1051 |
|
|
"foreach ns [namespace children $root] {\n"
|
1052 |
|
|
"eval lappend list [::tcl::GetAllNamespaces $ns]\n"
|
1053 |
|
|
"}\n"
|
1054 |
|
|
"return $list\n"
|
1055 |
|
|
"}\n"
|
1056 |
|
|
"foreach ::tcl::x [::tcl::GetAllNamespaces] {\n"
|
1057 |
|
|
"set ::tcl::namespaces($::tcl::x) 1\n"
|
1058 |
|
|
"}\n"
|
1059 |
|
|
"foreach ::tcl::x [package names] {\n"
|
1060 |
|
|
"set ::tcl::packages($::tcl::x) 1\n"
|
1061 |
|
|
"}\n"
|
1062 |
|
|
"set ::tcl::origCmds [info commands]\n"
|
1063 |
|
|
"if {[pkg_compareExtension $::tcl::file [info sharedlibextension]]} {\n"
|
1064 |
|
|
"set ::tcl::debug loading\n"
|
1065 |
|
|
"load [file join . $::tcl::file]\n"
|
1066 |
|
|
"set ::tcl::type load\n"
|
1067 |
|
|
"} else {\n"
|
1068 |
|
|
"set ::tcl::debug sourcing\n"
|
1069 |
|
|
"source $::tcl::file\n"
|
1070 |
|
|
"set ::tcl::type source\n"
|
1071 |
|
|
"}\n"
|
1072 |
|
|
"if { !$::tcl::direct } {\n"
|
1073 |
|
|
"foreach ::tcl::x [::tcl::GetAllNamespaces] {\n"
|
1074 |
|
|
"if {! [info exists ::tcl::namespaces($::tcl::x)]} {\n"
|
1075 |
|
|
"namespace import -force ${::tcl::x}::*\n"
|
1076 |
|
|
"}\n"
|
1077 |
|
|
"foreach ::tcl::x [info commands] {\n"
|
1078 |
|
|
"set ::tcl::newCmds($::tcl::x) 1\n"
|
1079 |
|
|
"}\n"
|
1080 |
|
|
"foreach ::tcl::x $::tcl::origCmds {\n"
|
1081 |
|
|
"catch {unset ::tcl::newCmds($::tcl::x)}\n"
|
1082 |
|
|
"}\n"
|
1083 |
|
|
"foreach ::tcl::x [array names ::tcl::newCmds] {\n"
|
1084 |
|
|
"set ::tcl::abs [namespace origin $::tcl::x]\n"
|
1085 |
|
|
"set ::tcl::abs \\\n"
|
1086 |
|
|
"\011\011\011\011 [lindex [auto_qualify $::tcl::abs ::] 0]\n"
|
1087 |
|
|
"if {[string compare $::tcl::x $::tcl::abs]} {\n"
|
1088 |
|
|
"set ::tcl::newCmds($::tcl::abs) 1\n"
|
1089 |
|
|
"unset ::tcl::newCmds($::tcl::x)\n"
|
1090 |
|
|
"}\n"
|
1091 |
|
|
"}\n"
|
1092 |
|
|
"}\n"
|
1093 |
|
|
"}\n"
|
1094 |
|
|
"foreach ::tcl::x [package names] {\n"
|
1095 |
|
|
"if {[string compare [package provide $::tcl::x] \"\"] \\\n"
|
1096 |
|
|
"\011\011\011 && ![info exists ::tcl::packages($::tcl::x)]} {\n"
|
1097 |
|
|
"lappend ::tcl::newPkgs \\\n"
|
1098 |
|
|
"\011\011\011 [list $::tcl::x [package provide $::tcl::x]]\n"
|
1099 |
|
|
"}\n"
|
1100 |
|
|
"}\n"
|
1101 |
|
|
"}\n"
|
1102 |
|
|
"} msg] == 1} {\n"
|
1103 |
|
|
"set what [$c eval set ::tcl::debug]\n"
|
1104 |
|
|
"if {$doVerbose} {\n"
|
1105 |
|
|
"tclLog \"warning: error while $what $file: $msg\"\n"
|
1106 |
|
|
"}\n"
|
1107 |
|
|
"} else {\n"
|
1108 |
|
|
"set type [$c eval set ::tcl::type]\n"
|
1109 |
|
|
"set cmds [lsort [$c eval array names ::tcl::newCmds]]\n"
|
1110 |
|
|
"set pkgs [$c eval set ::tcl::newPkgs]\n"
|
1111 |
|
|
"if {[llength $pkgs] > 1} {\n"
|
1112 |
|
|
"tclLog \"warning: \\\"$file\\\" provides more than one package ($pkgs)\"\n"
|
1113 |
|
|
"}\n"
|
1114 |
|
|
"foreach pkg $pkgs {\n"
|
1115 |
|
|
"lappend files($pkg) [list $file $type $cmds]\n"
|
1116 |
|
|
"}\n"
|
1117 |
|
|
"if {$doVerbose} {\n"
|
1118 |
|
|
"tclLog \"processed $file\"\n"
|
1119 |
|
|
"}\n"
|
1120 |
|
|
"interp delete $c\n"
|
1121 |
|
|
"}\n"
|
1122 |
|
|
"}\n"
|
1123 |
|
|
"append index \"# Tcl package index file, version 1.1\\n\"\n"
|
1124 |
|
|
"append index \"# This file is generated by the \\\"pkg_mkIndex$more\\\" command\\n\"\n"
|
1125 |
|
|
"append index \"# and sourced either when an application starts up or\\n\"\n"
|
1126 |
|
|
"append index \"# by a \\\"package unknown\\\" script. It invokes the\\n\"\n"
|
1127 |
|
|
"append index \"# \\\"package ifneeded\\\" command to set up package-related\\n\"\n"
|
1128 |
|
|
"append index \"# information so that packages will be loaded automatically\\n\"\n"
|
1129 |
|
|
"append index \"# in response to \\\"package require\\\" commands. When this\\n\"\n"
|
1130 |
|
|
"append index \"# script is sourced, the variable \\$dir must contain the\\n\"\n"
|
1131 |
|
|
"append index \"# full path name of this file's directory.\\n\"\n"
|
1132 |
|
|
"foreach pkg [lsort [array names files]] {\n"
|
1133 |
|
|
"set cmd {}\n"
|
1134 |
|
|
"foreach {name version} $pkg {\n"
|
1135 |
|
|
"break\n"
|
1136 |
|
|
"}\n"
|
1137 |
|
|
"lappend cmd ::pkg::create -name $name -version $version\n"
|
1138 |
|
|
"foreach spec $files($pkg) {\n"
|
1139 |
|
|
"foreach {file type procs} $spec {\n"
|
1140 |
|
|
"if { $direct } {\n"
|
1141 |
|
|
"set procs {}\n"
|
1142 |
|
|
"}\n"
|
1143 |
|
|
"lappend cmd \"-$type\" [list $file $procs]\n"
|
1144 |
|
|
"}\n"
|
1145 |
|
|
"}\n"
|
1146 |
|
|
"append index \"\\n[eval $cmd]\"\n"
|
1147 |
|
|
"}\n"
|
1148 |
|
|
"set f [open pkgIndex.tcl w]\n"
|
1149 |
|
|
"puts $f $index\n"
|
1150 |
|
|
"close $f\n"
|
1151 |
|
|
"cd $oldDir\n"
|
1152 |
|
|
"}\n"
|
1153 |
|
|
"proc tclPkgSetup {dir pkg version files} {\n"
|
1154 |
|
|
"global auto_index\n"
|
1155 |
|
|
"package provide $pkg $version\n"
|
1156 |
|
|
"foreach fileInfo $files {\n"
|
1157 |
|
|
"set f [lindex $fileInfo 0]\n"
|
1158 |
|
|
"set type [lindex $fileInfo 1]\n"
|
1159 |
|
|
"foreach cmd [lindex $fileInfo 2] {\n"
|
1160 |
|
|
"if {[string equal $type \"load\"]} {\n"
|
1161 |
|
|
"set auto_index($cmd) [list load [file join $dir $f] $pkg]\n"
|
1162 |
|
|
"} else {\n"
|
1163 |
|
|
"set auto_index($cmd) [list source [file join $dir $f]]\n"
|
1164 |
|
|
"} \n"
|
1165 |
|
|
"}\n"
|
1166 |
|
|
"}\n"
|
1167 |
|
|
"}\n"
|
1168 |
|
|
"proc tclMacPkgSearch {dir} {\n"
|
1169 |
|
|
"foreach x [glob -nocomplain [file join $dir *.shlb]] {\n"
|
1170 |
|
|
"if {[file isfile $x]} {\n"
|
1171 |
|
|
"set res [resource open $x]\n"
|
1172 |
|
|
"foreach y [resource list TEXT $res] {\n"
|
1173 |
|
|
"if {[string equal $y \"pkgIndex\"]} {source -rsrc pkgIndex}\n"
|
1174 |
|
|
"}\n"
|
1175 |
|
|
"catch {resource close $res}\n"
|
1176 |
|
|
"}\n"
|
1177 |
|
|
"}\n"
|
1178 |
|
|
"}\n"
|
1179 |
|
|
"proc tclPkgUnknown {name version {exact {}}} {\n"
|
1180 |
|
|
"global auto_path tcl_platform env\n"
|
1181 |
|
|
"if {![info exists auto_path]} {\n"
|
1182 |
|
|
"return\n"
|
1183 |
|
|
"}\n"
|
1184 |
|
|
"set old_path [set use_path $auto_path]\n"
|
1185 |
|
|
"while {[llength $use_path]} {\n"
|
1186 |
|
|
"set dir [lindex $use_path end]\n"
|
1187 |
|
|
"catch {\n"
|
1188 |
|
|
"foreach file [glob -nocomplain [file join $dir * pkgIndex.tcl]] {\n"
|
1189 |
|
|
"set dir [file dirname $file]\n"
|
1190 |
|
|
"if {[file readable $file] && ![info exists procdDirs($dir)]} {\n"
|
1191 |
|
|
"if {[catch {source $file} msg]} {\n"
|
1192 |
|
|
"tclLog \"error reading package index file $file: $msg\"\n"
|
1193 |
|
|
"} else {\n"
|
1194 |
|
|
"set procdDirs($dir) 1\n"
|
1195 |
|
|
"}\n"
|
1196 |
|
|
"}\n"
|
1197 |
|
|
"}\n"
|
1198 |
|
|
"}\n"
|
1199 |
|
|
"set dir [lindex $use_path end]\n"
|
1200 |
|
|
"set file [file join $dir pkgIndex.tcl]\n"
|
1201 |
|
|
"if {([interp issafe] || [file readable $file]) && \\\n"
|
1202 |
|
|
"\011\011![info exists procdDirs($dir)]} {\n"
|
1203 |
|
|
"if {[catch {source $file} msg] && ![interp issafe]} {\n"
|
1204 |
|
|
"tclLog \"error reading package index file $file: $msg\"\n"
|
1205 |
|
|
"} else {\n"
|
1206 |
|
|
"set procdDirs($dir) 1\n"
|
1207 |
|
|
"}\n"
|
1208 |
|
|
"}\n"
|
1209 |
|
|
"if {(![interp issafe]) && \\\n"
|
1210 |
|
|
"\011\011[string equal $tcl_platform(platform) \"macintosh\"]} {\n"
|
1211 |
|
|
"set dir [lindex $use_path end]\n"
|
1212 |
|
|
"if {![info exists procdDirs($dir)]} {\n"
|
1213 |
|
|
"tclMacPkgSearch $dir\n"
|
1214 |
|
|
"set procdDirs($dir) 1\n"
|
1215 |
|
|
"}\n"
|
1216 |
|
|
"foreach x [glob -nocomplain [file join $dir *]] {\n"
|
1217 |
|
|
"if {[file isdirectory $x] && ![info exists procdDirs($x)]} {\n"
|
1218 |
|
|
"set dir $x\n"
|
1219 |
|
|
"tclMacPkgSearch $dir\n"
|
1220 |
|
|
"set procdDirs($dir) 1\n"
|
1221 |
|
|
"}\n"
|
1222 |
|
|
"}\n"
|
1223 |
|
|
"}\n"
|
1224 |
|
|
"set use_path [lrange $use_path 0 end-1]\n"
|
1225 |
|
|
"if {[string compare $old_path $auto_path]} {\n"
|
1226 |
|
|
"foreach dir $auto_path {\n"
|
1227 |
|
|
"lappend use_path $dir\n"
|
1228 |
|
|
"}\n"
|
1229 |
|
|
"set old_path $auto_path\n"
|
1230 |
|
|
"}\n"
|
1231 |
|
|
"}\n"
|
1232 |
|
|
"}\n"
|
1233 |
|
|
"proc ::pkg::create {args} {\n"
|
1234 |
|
|
"append err(usage) \"[lindex [info level 0] 0] \"\n"
|
1235 |
|
|
"append err(usage) \"-name packageName -version packageVersion\"\n"
|
1236 |
|
|
"append err(usage) \"?-load {filename ?{procs}?}? ... \"\n"
|
1237 |
|
|
"append err(usage) \"?-source {filename ?{procs}?}? ...\"\n"
|
1238 |
|
|
"set err(wrongNumArgs) \"wrong # args: should be \\\"$err(usage)\\\"\"\n"
|
1239 |
|
|
"set err(valueMissing) \"value for \\\"%s\\\" missing: should be \\\"$err(usage)\\\"\"\n"
|
1240 |
|
|
"set err(unknownOpt) \"unknown option \\\"%s\\\": should be \\\"$err(usage)\\\"\"\n"
|
1241 |
|
|
"set err(noLoadOrSource) \"at least one of -load and -source must be given\"\n"
|
1242 |
|
|
"set len [llength $args]\n"
|
1243 |
|
|
"if { $len < 6 } {\n"
|
1244 |
|
|
"error $err(wrongNumArgs)\n"
|
1245 |
|
|
"}\n"
|
1246 |
|
|
"set opts(-name)\011\011{}\n"
|
1247 |
|
|
"set opts(-version)\011\011{}\n"
|
1248 |
|
|
"set opts(-source)\011\011{}\n"
|
1249 |
|
|
"set opts(-load)\011\011{}\n"
|
1250 |
|
|
"for {set i 0} {$i < $len} {incr i} {\n"
|
1251 |
|
|
"set flag [lindex $args $i]\n"
|
1252 |
|
|
"incr i\n"
|
1253 |
|
|
"switch -glob -- $flag {\n"
|
1254 |
|
|
"\"-name\"\011\011-\n"
|
1255 |
|
|
"\"-version\"\011\011{\n"
|
1256 |
|
|
"if { $i >= $len } {\n"
|
1257 |
|
|
"error [format $err(valueMissing) $flag]\n"
|
1258 |
|
|
"}\n"
|
1259 |
|
|
"set opts($flag) [lindex $args $i]\n"
|
1260 |
|
|
"}\n"
|
1261 |
|
|
"\"-source\"\011\011-\n"
|
1262 |
|
|
"\"-load\"\011\011{\n"
|
1263 |
|
|
"if { $i >= $len } {\n"
|
1264 |
|
|
"error [format $err(valueMissing) $flag]\n"
|
1265 |
|
|
"}\n"
|
1266 |
|
|
"lappend opts($flag) [lindex $args $i]\n"
|
1267 |
|
|
"}\n"
|
1268 |
|
|
"default {\n"
|
1269 |
|
|
"error [format $err(unknownOpt) [lindex $args $i]]\n"
|
1270 |
|
|
"}\n"
|
1271 |
|
|
"}\n"
|
1272 |
|
|
"}\n"
|
1273 |
|
|
"if { [llength $opts(-name)] == 0 } {\n"
|
1274 |
|
|
"error [format $err(valueMissing) \"-name\"]\n"
|
1275 |
|
|
"}\n"
|
1276 |
|
|
"if { [llength $opts(-version)] == 0 } {\n"
|
1277 |
|
|
"error [format $err(valueMissing) \"-version\"]\n"
|
1278 |
|
|
"}\n"
|
1279 |
|
|
"if { [llength $opts(-source)] == 0 && [llength $opts(-load)] == 0 } {\n"
|
1280 |
|
|
"error $err(noLoadOrSource)\n"
|
1281 |
|
|
"}\n"
|
1282 |
|
|
"set cmdline \"package ifneeded $opts(-name) $opts(-version) \"\n"
|
1283 |
|
|
"set cmdList {}\n"
|
1284 |
|
|
"set lazyFileList {}\n"
|
1285 |
|
|
"foreach key {load source} {\n"
|
1286 |
|
|
"foreach filespec $opts(-$key) {\n"
|
1287 |
|
|
"foreach {filename proclist} {{} {}} {\n"
|
1288 |
|
|
"break\n"
|
1289 |
|
|
"}\n"
|
1290 |
|
|
"foreach {filename proclist} $filespec {\n"
|
1291 |
|
|
"break\n"
|
1292 |
|
|
"}\n"
|
1293 |
|
|
"if { [llength $proclist] == 0 } {\n"
|
1294 |
|
|
"set cmd \"\\[list $key \\[file join \\$dir [list $filename]\\]\\]\"\n"
|
1295 |
|
|
"lappend cmdList $cmd\n"
|
1296 |
|
|
"} else {\n"
|
1297 |
|
|
"lappend lazyFileList [list $filename $key $proclist]\n"
|
1298 |
|
|
"}\n"
|
1299 |
|
|
"}\n"
|
1300 |
|
|
"}\n"
|
1301 |
|
|
"if { [llength $lazyFileList] > 0 } {\n"
|
1302 |
|
|
"lappend cmdList \"\\[list tclPkgSetup \\$dir $opts(-name)\\\n"
|
1303 |
|
|
"\011\011$opts(-version) [list $lazyFileList]\\]\"\n"
|
1304 |
|
|
"}\n"
|
1305 |
|
|
"append cmdline [join $cmdList \"\\\\n\"]\n"
|
1306 |
|
|
"return $cmdline\n"
|
1307 |
|
|
"}\n"
|
1308 |
|
|
;
|
1309 |
|
|
static char Et_zFile4[] =
|
1310 |
|
|
"proc parray {a {pattern *}} {\n"
|
1311 |
|
|
"upvar 1 $a array\n"
|
1312 |
|
|
"if {![array exists array]} {\n"
|
1313 |
|
|
"error \"\\\"$a\\\" isn't an array\"\n"
|
1314 |
|
|
"}\n"
|
1315 |
|
|
"set maxl 0\n"
|
1316 |
|
|
"foreach name [lsort [array names array $pattern]] {\n"
|
1317 |
|
|
"if {[string length $name] > $maxl} {\n"
|
1318 |
|
|
"set maxl [string length $name]\n"
|
1319 |
|
|
"}\n"
|
1320 |
|
|
"}\n"
|
1321 |
|
|
"set maxl [expr {$maxl + [string length $a] + 2}]\n"
|
1322 |
|
|
"foreach name [lsort [array names array $pattern]] {\n"
|
1323 |
|
|
"set nameString [format %s(%s) $a $name]\n"
|
1324 |
|
|
"puts stdout [format \"%-*s = %s\" $maxl $nameString $array($name)]\n"
|
1325 |
|
|
"}\n"
|
1326 |
|
|
"}\n"
|
1327 |
|
|
;
|
1328 |
|
|
static char Et_zFile5[] =
|
1329 |
|
|
"package require opt 0.4.1;\n"
|
1330 |
|
|
"namespace eval ::safe {\n"
|
1331 |
|
|
"namespace export interpCreate interpInit interpConfigure interpDelete \\\n"
|
1332 |
|
|
"\011 interpAddToAccessPath interpFindInAccessPath setLogCmd\n"
|
1333 |
|
|
"set temp [::tcl::OptKeyRegister {\n"
|
1334 |
|
|
"{-accessPath -list {} \"access path for the slave\"}\n"
|
1335 |
|
|
"{-noStatics \"prevent loading of statically linked pkgs\"}\n"
|
1336 |
|
|
"{-statics true \"loading of statically linked pkgs\"}\n"
|
1337 |
|
|
"{-nestedLoadOk \"allow nested loading\"}\n"
|
1338 |
|
|
"{-nested false \"nested loading\"}\n"
|
1339 |
|
|
"{-deleteHook -script {} \"delete hook\"}\n"
|
1340 |
|
|
"}]\n"
|
1341 |
|
|
"::tcl::OptKeyRegister {\n"
|
1342 |
|
|
"{?slave? -name {} \"name of the slave (optional)\"}\n"
|
1343 |
|
|
"} ::safe::interpCreate\n"
|
1344 |
|
|
"lappend ::tcl::OptDesc(::safe::interpCreate) $::tcl::OptDesc($temp)\n"
|
1345 |
|
|
"::tcl::OptKeyRegister {\n"
|
1346 |
|
|
"{slave -name {} \"name of the slave\"}\n"
|
1347 |
|
|
"} ::safe::interpIC\n"
|
1348 |
|
|
"lappend ::tcl::OptDesc(::safe::interpIC) $::tcl::OptDesc($temp)\n"
|
1349 |
|
|
"::tcl::OptKeyDelete $temp\n"
|
1350 |
|
|
"proc InterpStatics {} {\n"
|
1351 |
|
|
"foreach v {Args statics noStatics} {\n"
|
1352 |
|
|
"upvar $v $v\n"
|
1353 |
|
|
"}\n"
|
1354 |
|
|
"set flag [::tcl::OptProcArgGiven -noStatics];\n"
|
1355 |
|
|
"if {$flag && ($noStatics == $statics) \n"
|
1356 |
|
|
"&& ([::tcl::OptProcArgGiven -statics])} {\n"
|
1357 |
|
|
"return -code error\\\n"
|
1358 |
|
|
"\011\011 \"conflicting values given for -statics and -noStatics\"\n"
|
1359 |
|
|
"}\n"
|
1360 |
|
|
"if {$flag} {\n"
|
1361 |
|
|
"return [expr {!$noStatics}]\n"
|
1362 |
|
|
"} else {\n"
|
1363 |
|
|
"return $statics\n"
|
1364 |
|
|
"}\n"
|
1365 |
|
|
"}\n"
|
1366 |
|
|
"proc InterpNested {} {\n"
|
1367 |
|
|
"foreach v {Args nested nestedLoadOk} {\n"
|
1368 |
|
|
"upvar $v $v\n"
|
1369 |
|
|
"}\n"
|
1370 |
|
|
"set flag [::tcl::OptProcArgGiven -nestedLoadOk];\n"
|
1371 |
|
|
"if {$flag && ($nestedLoadOk != $nested) \n"
|
1372 |
|
|
"&& ([::tcl::OptProcArgGiven -nested])} {\n"
|
1373 |
|
|
"return -code error\\\n"
|
1374 |
|
|
"\011\011 \"conflicting values given for -nested and -nestedLoadOk\"\n"
|
1375 |
|
|
"}\n"
|
1376 |
|
|
"if {$flag} {\n"
|
1377 |
|
|
"return $nestedLoadOk\n"
|
1378 |
|
|
"} else {\n"
|
1379 |
|
|
"return $nested\n"
|
1380 |
|
|
"}\n"
|
1381 |
|
|
"}\n"
|
1382 |
|
|
"proc interpCreate {args} {\n"
|
1383 |
|
|
"set Args [::tcl::OptKeyParse ::safe::interpCreate $args]\n"
|
1384 |
|
|
"InterpCreate $slave $accessPath \\\n"
|
1385 |
|
|
"\011\011[InterpStatics] [InterpNested] $deleteHook\n"
|
1386 |
|
|
"}\n"
|
1387 |
|
|
"proc interpInit {args} {\n"
|
1388 |
|
|
"set Args [::tcl::OptKeyParse ::safe::interpIC $args]\n"
|
1389 |
|
|
"if {![::interp exists $slave]} {\n"
|
1390 |
|
|
"return -code error \"\\\"$slave\\\" is not an interpreter\"\n"
|
1391 |
|
|
"}\n"
|
1392 |
|
|
"InterpInit $slave $accessPath \\\n"
|
1393 |
|
|
"\011\011[InterpStatics] [InterpNested] $deleteHook;\n"
|
1394 |
|
|
"}\n"
|
1395 |
|
|
"proc CheckInterp {slave} {\n"
|
1396 |
|
|
"if {![IsInterp $slave]} {\n"
|
1397 |
|
|
"return -code error \\\n"
|
1398 |
|
|
"\011\011 \"\\\"$slave\\\" is not an interpreter managed by ::safe::\"\n"
|
1399 |
|
|
"}\n"
|
1400 |
|
|
"}\n"
|
1401 |
|
|
"proc interpConfigure {args} {\n"
|
1402 |
|
|
"switch [llength $args] {\n"
|
1403 |
|
|
"1 {\n"
|
1404 |
|
|
"set Args [::tcl::OptKeyParse ::safe::interpIC $args]\n"
|
1405 |
|
|
"CheckInterp $slave\n"
|
1406 |
|
|
"set res {}\n"
|
1407 |
|
|
"lappend res [list -accessPath [Set [PathListName $slave]]]\n"
|
1408 |
|
|
"lappend res [list -statics [Set [StaticsOkName $slave]]]\n"
|
1409 |
|
|
"lappend res [list -nested [Set [NestedOkName $slave]]]\n"
|
1410 |
|
|
"lappend res [list -deleteHook [Set [DeleteHookName $slave]]]\n"
|
1411 |
|
|
"join $res\n"
|
1412 |
|
|
"}\n"
|
1413 |
|
|
"2 {\n"
|
1414 |
|
|
"::tcl::Lassign $args slave arg\n"
|
1415 |
|
|
"set desc [lindex [::tcl::OptKeyGetDesc ::safe::interpIC] 2]\n"
|
1416 |
|
|
"set hits [::tcl::OptHits desc $arg]\n"
|
1417 |
|
|
"if {$hits > 1} {\n"
|
1418 |
|
|
"return -code error [::tcl::OptAmbigous $desc $arg]\n"
|
1419 |
|
|
"} elseif {$hits == 0} {\n"
|
1420 |
|
|
"return -code error [::tcl::OptFlagUsage $desc $arg]\n"
|
1421 |
|
|
"}\n"
|
1422 |
|
|
"CheckInterp $slave\n"
|
1423 |
|
|
"set item [::tcl::OptCurDesc $desc]\n"
|
1424 |
|
|
"set name [::tcl::OptName $item]\n"
|
1425 |
|
|
"switch -exact -- $name {\n"
|
1426 |
|
|
"-accessPath {\n"
|
1427 |
|
|
"return [list -accessPath [Set [PathListName $slave]]]\n"
|
1428 |
|
|
"}\n"
|
1429 |
|
|
"-statics {\n"
|
1430 |
|
|
"return [list -statics [Set [StaticsOkName $slave]]]\n"
|
1431 |
|
|
"}\n"
|
1432 |
|
|
"-nested {\n"
|
1433 |
|
|
"return [list -nested [Set [NestedOkName $slave]]]\n"
|
1434 |
|
|
"}\n"
|
1435 |
|
|
"-deleteHook {\n"
|
1436 |
|
|
"return [list -deleteHook [Set [DeleteHookName $slave]]]\n"
|
1437 |
|
|
"}\n"
|
1438 |
|
|
"-noStatics {\n"
|
1439 |
|
|
"return -code error\\\n"
|
1440 |
|
|
"\011\011\011\011\"ambigous query (get or set -noStatics ?)\\\n"
|
1441 |
|
|
"\011\011\011\011use -statics instead\"\n"
|
1442 |
|
|
"}\n"
|
1443 |
|
|
"-nestedLoadOk {\n"
|
1444 |
|
|
"return -code error\\\n"
|
1445 |
|
|
"\011\011\011\011\"ambigous query (get or set -nestedLoadOk ?)\\\n"
|
1446 |
|
|
"\011\011\011\011use -nested instead\"\n"
|
1447 |
|
|
"}\n"
|
1448 |
|
|
"default {\n"
|
1449 |
|
|
"return -code error \"unknown flag $name (bug)\"\n"
|
1450 |
|
|
"}\n"
|
1451 |
|
|
"}\n"
|
1452 |
|
|
"}\n"
|
1453 |
|
|
"default {\n"
|
1454 |
|
|
"set Args [::tcl::OptKeyParse ::safe::interpIC $args]\n"
|
1455 |
|
|
"CheckInterp $slave\n"
|
1456 |
|
|
"if {![::tcl::OptProcArgGiven -accessPath]} {\n"
|
1457 |
|
|
"set doreset 1\n"
|
1458 |
|
|
"set accessPath [Set [PathListName $slave]]\n"
|
1459 |
|
|
"} else {\n"
|
1460 |
|
|
"set doreset 0\n"
|
1461 |
|
|
"}\n"
|
1462 |
|
|
"if {(![::tcl::OptProcArgGiven -statics]) \\\n"
|
1463 |
|
|
"\011\011\011&& (![::tcl::OptProcArgGiven -noStatics]) } {\n"
|
1464 |
|
|
"set statics [Set [StaticsOkName $slave]]\n"
|
1465 |
|
|
"} else {\n"
|
1466 |
|
|
"set statics [InterpStatics]\n"
|
1467 |
|
|
"}\n"
|
1468 |
|
|
"if {([::tcl::OptProcArgGiven -nested]) \\\n"
|
1469 |
|
|
"\011\011\011|| ([::tcl::OptProcArgGiven -nestedLoadOk]) } {\n"
|
1470 |
|
|
"set nested [InterpNested]\n"
|
1471 |
|
|
"} else {\n"
|
1472 |
|
|
"set nested [Set [NestedOkName $slave]]\n"
|
1473 |
|
|
"}\n"
|
1474 |
|
|
"if {![::tcl::OptProcArgGiven -deleteHook]} {\n"
|
1475 |
|
|
"set deleteHook [Set [DeleteHookName $slave]]\n"
|
1476 |
|
|
"}\n"
|
1477 |
|
|
"InterpSetConfig $slave $accessPath $statics $nested $deleteHook\n"
|
1478 |
|
|
"if {$doreset} {\n"
|
1479 |
|
|
"if {[catch {::interp eval $slave {auto_reset}} msg]} {\n"
|
1480 |
|
|
"Log $slave \"auto_reset failed: $msg\"\n"
|
1481 |
|
|
"} else {\n"
|
1482 |
|
|
"Log $slave \"successful auto_reset\" NOTICE\n"
|
1483 |
|
|
"}\n"
|
1484 |
|
|
"}\n"
|
1485 |
|
|
"}\n"
|
1486 |
|
|
"}\n"
|
1487 |
|
|
"}\n"
|
1488 |
|
|
"proc ::safe::InterpCreate {\n"
|
1489 |
|
|
"slave \n"
|
1490 |
|
|
"access_path\n"
|
1491 |
|
|
"staticsok\n"
|
1492 |
|
|
"nestedok\n"
|
1493 |
|
|
"deletehook\n"
|
1494 |
|
|
"} {\n"
|
1495 |
|
|
"if {[string compare \"\" $slave]} {\n"
|
1496 |
|
|
"::interp create -safe $slave\n"
|
1497 |
|
|
"} else {\n"
|
1498 |
|
|
"set slave [::interp create -safe]\n"
|
1499 |
|
|
"}\n"
|
1500 |
|
|
"Log $slave \"Created\" NOTICE\n"
|
1501 |
|
|
"InterpInit $slave $access_path $staticsok $nestedok $deletehook\n"
|
1502 |
|
|
"}\n"
|
1503 |
|
|
"proc ::safe::InterpSetConfig {slave access_path staticsok\\\n"
|
1504 |
|
|
"\011 nestedok deletehook} {\n"
|
1505 |
|
|
"if {[string equal \"\" $access_path]} {\n"
|
1506 |
|
|
"set access_path [uplevel #0 set auto_path]\n"
|
1507 |
|
|
"set where [lsearch -exact $access_path [info library]]\n"
|
1508 |
|
|
"if {$where == -1} {\n"
|
1509 |
|
|
"set access_path [concat [list [info library]] $access_path]\n"
|
1510 |
|
|
"Log $slave \"tcl_library was not in auto_path,\\\n"
|
1511 |
|
|
"\011\011\011added it to slave's access_path\" NOTICE\n"
|
1512 |
|
|
"} elseif {$where != 0} {\n"
|
1513 |
|
|
"set access_path [concat [list [info library]]\\\n"
|
1514 |
|
|
"\011\011\011[lreplace $access_path $where $where]]\n"
|
1515 |
|
|
"Log $slave \"tcl_libray was not in first in auto_path,\\\n"
|
1516 |
|
|
"\011\011\011moved it to front of slave's access_path\" NOTICE\n"
|
1517 |
|
|
"}\n"
|
1518 |
|
|
"set access_path [AddSubDirs $access_path]\n"
|
1519 |
|
|
"}\n"
|
1520 |
|
|
"Log $slave \"Setting accessPath=($access_path) staticsok=$staticsok\\\n"
|
1521 |
|
|
"\011\011nestedok=$nestedok deletehook=($deletehook)\" NOTICE\n"
|
1522 |
|
|
"set nname [PathNumberName $slave]\n"
|
1523 |
|
|
"if {[Exists $nname]} {\n"
|
1524 |
|
|
"set n [Set $nname]\n"
|
1525 |
|
|
"for {set i 0} {$i<$n} {incr i} {\n"
|
1526 |
|
|
"Unset [PathToken $i $slave]\n"
|
1527 |
|
|
"}\n"
|
1528 |
|
|
"}\n"
|
1529 |
|
|
"set slave_auto_path {}\n"
|
1530 |
|
|
"set i 0\n"
|
1531 |
|
|
"foreach dir $access_path {\n"
|
1532 |
|
|
"Set [PathToken $i $slave] $dir\n"
|
1533 |
|
|
"lappend slave_auto_path \"\\$[PathToken $i]\"\n"
|
1534 |
|
|
"incr i\n"
|
1535 |
|
|
"}\n"
|
1536 |
|
|
"Set $nname $i\n"
|
1537 |
|
|
"Set [PathListName $slave] $access_path\n"
|
1538 |
|
|
"Set [VirtualPathListName $slave] $slave_auto_path\n"
|
1539 |
|
|
"Set [StaticsOkName $slave] $staticsok\n"
|
1540 |
|
|
"Set [NestedOkName $slave] $nestedok\n"
|
1541 |
|
|
"Set [DeleteHookName $slave] $deletehook\n"
|
1542 |
|
|
"SyncAccessPath $slave\n"
|
1543 |
|
|
"}\n"
|
1544 |
|
|
"proc ::safe::interpFindInAccessPath {slave path} {\n"
|
1545 |
|
|
"set access_path [GetAccessPath $slave]\n"
|
1546 |
|
|
"set where [lsearch -exact $access_path $path]\n"
|
1547 |
|
|
"if {$where == -1} {\n"
|
1548 |
|
|
"return -code error \"$path not found in access path $access_path\"\n"
|
1549 |
|
|
"}\n"
|
1550 |
|
|
"return \"\\$[PathToken $where]\"\n"
|
1551 |
|
|
"}\n"
|
1552 |
|
|
"proc ::safe::interpAddToAccessPath {slave path} {\n"
|
1553 |
|
|
"if {![catch {interpFindInAccessPath $slave $path} res]} {\n"
|
1554 |
|
|
"return $res\n"
|
1555 |
|
|
"}\n"
|
1556 |
|
|
"set nname [PathNumberName $slave]\n"
|
1557 |
|
|
"set n [Set $nname]\n"
|
1558 |
|
|
"Set [PathToken $n $slave] $path\n"
|
1559 |
|
|
"set token \"\\$[PathToken $n]\"\n"
|
1560 |
|
|
"Lappend [VirtualPathListName $slave] $token\n"
|
1561 |
|
|
"Lappend [PathListName $slave] $path\n"
|
1562 |
|
|
"Set $nname [expr {$n+1}]\n"
|
1563 |
|
|
"SyncAccessPath $slave\n"
|
1564 |
|
|
"return $token\n"
|
1565 |
|
|
"}\n"
|
1566 |
|
|
"proc ::safe::InterpInit {\n"
|
1567 |
|
|
"slave \n"
|
1568 |
|
|
"access_path\n"
|
1569 |
|
|
"staticsok\n"
|
1570 |
|
|
"nestedok\n"
|
1571 |
|
|
"deletehook\n"
|
1572 |
|
|
"} {\n"
|
1573 |
|
|
"InterpSetConfig $slave $access_path $staticsok $nestedok $deletehook\n"
|
1574 |
|
|
"::interp alias $slave source {} [namespace current]::AliasSource $slave\n"
|
1575 |
|
|
"::interp alias $slave load {} [namespace current]::AliasLoad $slave\n"
|
1576 |
|
|
"::interp alias $slave encoding {} [namespace current]::AliasEncoding \\\n"
|
1577 |
|
|
"\011\011$slave\n"
|
1578 |
|
|
"AliasSubset $slave file file dir.* join root.* ext.* tail \\\n"
|
1579 |
|
|
"\011\011path.* split\n"
|
1580 |
|
|
"::interp alias $slave exit {} [namespace current]::interpDelete $slave\n"
|
1581 |
|
|
"if {[catch {::interp eval $slave\\\n"
|
1582 |
|
|
"\011\011{source [file join $tcl_library init.tcl]}} msg]} {\n"
|
1583 |
|
|
"Log $slave \"can't source init.tcl ($msg)\"\n"
|
1584 |
|
|
"error \"can't source init.tcl into slave $slave ($msg)\"\n"
|
1585 |
|
|
"}\n"
|
1586 |
|
|
"return $slave\n"
|
1587 |
|
|
"}\n"
|
1588 |
|
|
"proc AddSubDirs {pathList} {\n"
|
1589 |
|
|
"set res {}\n"
|
1590 |
|
|
"foreach dir $pathList {\n"
|
1591 |
|
|
"if {[file isdirectory $dir]} {\n"
|
1592 |
|
|
"if {[lsearch -exact $res $dir]<0} {\n"
|
1593 |
|
|
"lappend res $dir\n"
|
1594 |
|
|
"}\n"
|
1595 |
|
|
"foreach sub [glob -nocomplain -- [file join $dir *]] {\n"
|
1596 |
|
|
"if {([file isdirectory $sub]) \\\n"
|
1597 |
|
|
"\011\011\011 && ([lsearch -exact $res $sub]<0) } {\n"
|
1598 |
|
|
"lappend res $sub\n"
|
1599 |
|
|
"}\n"
|
1600 |
|
|
"}\n"
|
1601 |
|
|
"}\n"
|
1602 |
|
|
"}\n"
|
1603 |
|
|
"return $res\n"
|
1604 |
|
|
"}\n"
|
1605 |
|
|
"proc ::safe::interpDelete {slave} {\n"
|
1606 |
|
|
"Log $slave \"About to delete\" NOTICE\n"
|
1607 |
|
|
"set hookname [DeleteHookName $slave]\n"
|
1608 |
|
|
"if {[Exists $hookname]} {\n"
|
1609 |
|
|
"set hook [Set $hookname]\n"
|
1610 |
|
|
"if {![::tcl::Lempty $hook]} {\n"
|
1611 |
|
|
"Unset $hookname\n"
|
1612 |
|
|
"if {[catch {eval $hook [list $slave]} err]} {\n"
|
1613 |
|
|
"Log $slave \"Delete hook error ($err)\"\n"
|
1614 |
|
|
"}\n"
|
1615 |
|
|
"}\n"
|
1616 |
|
|
"}\n"
|
1617 |
|
|
"set statename [InterpStateName $slave]\n"
|
1618 |
|
|
"if {[Exists $statename]} {\n"
|
1619 |
|
|
"Unset $statename\n"
|
1620 |
|
|
"}\n"
|
1621 |
|
|
"if {[::interp exists $slave]} {\n"
|
1622 |
|
|
"::interp delete $slave\n"
|
1623 |
|
|
"Log $slave \"Deleted\" NOTICE\n"
|
1624 |
|
|
"}\n"
|
1625 |
|
|
"return\n"
|
1626 |
|
|
"}\n"
|
1627 |
|
|
"proc ::safe::setLogCmd {args} {\n"
|
1628 |
|
|
"variable Log\n"
|
1629 |
|
|
"if {[llength $args] == 0} {\n"
|
1630 |
|
|
"return $Log\n"
|
1631 |
|
|
"} else {\n"
|
1632 |
|
|
"if {[llength $args] == 1} {\n"
|
1633 |
|
|
"set Log [lindex $args 0]\n"
|
1634 |
|
|
"} else {\n"
|
1635 |
|
|
"set Log $args\n"
|
1636 |
|
|
"}\n"
|
1637 |
|
|
"}\n"
|
1638 |
|
|
"}\n"
|
1639 |
|
|
"variable Log {}\n"
|
1640 |
|
|
"proc SyncAccessPath {slave} {\n"
|
1641 |
|
|
"set slave_auto_path [Set [VirtualPathListName $slave]]\n"
|
1642 |
|
|
"::interp eval $slave [list set auto_path $slave_auto_path]\n"
|
1643 |
|
|
"Log $slave \"auto_path in $slave has been set to $slave_auto_path\"\\\n"
|
1644 |
|
|
"\011\011NOTICE\n"
|
1645 |
|
|
"::interp eval $slave [list set tcl_library [lindex $slave_auto_path 0]]\n"
|
1646 |
|
|
"}\n"
|
1647 |
|
|
"proc InterpStateName {slave} {\n"
|
1648 |
|
|
"return \"S$slave\"\n"
|
1649 |
|
|
"}\n"
|
1650 |
|
|
"proc IsInterp {slave} {\n"
|
1651 |
|
|
"expr {[Exists [InterpStateName $slave]] && [::interp exists $slave]}\n"
|
1652 |
|
|
"}\n"
|
1653 |
|
|
"proc PathToken {n {slave \"\"}} {\n"
|
1654 |
|
|
"if {[string compare \"\" $slave]} {\n"
|
1655 |
|
|
"return \"[InterpStateName $slave](access_path,$n)\"\n"
|
1656 |
|
|
"} else {\n"
|
1657 |
|
|
"return \"p(:$n:)\"\n"
|
1658 |
|
|
"}\n"
|
1659 |
|
|
"}\n"
|
1660 |
|
|
"proc PathListName {slave} {\n"
|
1661 |
|
|
"return \"[InterpStateName $slave](access_path)\"\n"
|
1662 |
|
|
"}\n"
|
1663 |
|
|
"proc VirtualPathListName {slave} {\n"
|
1664 |
|
|
"return \"[InterpStateName $slave](access_path_slave)\"\n"
|
1665 |
|
|
"}\n"
|
1666 |
|
|
"proc PathNumberName {slave} {\n"
|
1667 |
|
|
"return \"[InterpStateName $slave](access_path,n)\"\n"
|
1668 |
|
|
"}\n"
|
1669 |
|
|
"proc StaticsOkName {slave} {\n"
|
1670 |
|
|
"return \"[InterpStateName $slave](staticsok)\"\n"
|
1671 |
|
|
"}\n"
|
1672 |
|
|
"proc NestedOkName {slave} {\n"
|
1673 |
|
|
"return \"[InterpStateName $slave](nestedok)\"\n"
|
1674 |
|
|
"}\n"
|
1675 |
|
|
"proc Toplevel {args} {\n"
|
1676 |
|
|
"namespace eval [namespace current] $args\n"
|
1677 |
|
|
"}\n"
|
1678 |
|
|
"proc Set {args} {\n"
|
1679 |
|
|
"eval Toplevel set $args\n"
|
1680 |
|
|
"}\n"
|
1681 |
|
|
"proc Lappend {args} {\n"
|
1682 |
|
|
"eval Toplevel lappend $args\n"
|
1683 |
|
|
"}\n"
|
1684 |
|
|
"proc Unset {args} {\n"
|
1685 |
|
|
"eval Toplevel unset $args\n"
|
1686 |
|
|
"}\n"
|
1687 |
|
|
"proc Exists {varname} {\n"
|
1688 |
|
|
"Toplevel info exists $varname\n"
|
1689 |
|
|
"}\n"
|
1690 |
|
|
"proc GetAccessPath {slave} {\n"
|
1691 |
|
|
"Set [PathListName $slave]\n"
|
1692 |
|
|
"}\n"
|
1693 |
|
|
"proc StaticsOk {slave} {\n"
|
1694 |
|
|
"Set [StaticsOkName $slave]\n"
|
1695 |
|
|
"}\n"
|
1696 |
|
|
"proc NestedOk {slave} {\n"
|
1697 |
|
|
"Set [NestedOkName $slave]\n"
|
1698 |
|
|
"}\n"
|
1699 |
|
|
"proc DeleteHookName {slave} {\n"
|
1700 |
|
|
"return [InterpStateName $slave](cleanupHook)\n"
|
1701 |
|
|
"}\n"
|
1702 |
|
|
"proc TranslatePath {slave path} {\n"
|
1703 |
|
|
"if {[regexp {(::)|(\\.\\.)} $path]} {\n"
|
1704 |
|
|
"error \"invalid characters in path $path\"\n"
|
1705 |
|
|
"}\n"
|
1706 |
|
|
"set n [expr {[Set [PathNumberName $slave]]-1}]\n"
|
1707 |
|
|
"for {} {$n>=0} {incr n -1} {\n"
|
1708 |
|
|
"set [PathToken $n] [Set [PathToken $n $slave]]\n"
|
1709 |
|
|
"}\n"
|
1710 |
|
|
"subst -nobackslashes -nocommands $path\n"
|
1711 |
|
|
"}\n"
|
1712 |
|
|
"proc Log {slave msg {type ERROR}} {\n"
|
1713 |
|
|
"variable Log\n"
|
1714 |
|
|
"if {[info exists Log] && [llength $Log]} {\n"
|
1715 |
|
|
"eval $Log [list \"$type for slave $slave : $msg\"]\n"
|
1716 |
|
|
"}\n"
|
1717 |
|
|
"}\n"
|
1718 |
|
|
"proc CheckFileName {slave file} {\n"
|
1719 |
|
|
"set ftail [file tail $file]\n"
|
1720 |
|
|
"if {[string length $ftail]>14} {\n"
|
1721 |
|
|
"error \"$ftail: filename too long\"\n"
|
1722 |
|
|
"}\n"
|
1723 |
|
|
"if {[regexp {\\..*\\.} $ftail]} {\n"
|
1724 |
|
|
"error \"$ftail: more than one dot is forbidden\"\n"
|
1725 |
|
|
"}\n"
|
1726 |
|
|
"if {[string compare $ftail \"tclIndex\"] && \\\n"
|
1727 |
|
|
"\011\011[string compare -nocase [file extension $ftail]\011\".tcl\"]} {\n"
|
1728 |
|
|
"error \"$ftail: must be a *.tcl or tclIndex\"\n"
|
1729 |
|
|
"}\n"
|
1730 |
|
|
"if {![file exists $file]} {\n"
|
1731 |
|
|
"error \"no such file or directory\"\n"
|
1732 |
|
|
"}\n"
|
1733 |
|
|
"if {![file readable $file]} {\n"
|
1734 |
|
|
"error \"not readable\"\n"
|
1735 |
|
|
"}\n"
|
1736 |
|
|
"}\n"
|
1737 |
|
|
"proc AliasSource {slave args} {\n"
|
1738 |
|
|
"set argc [llength $args]\n"
|
1739 |
|
|
"if {$argc != 1} {\n"
|
1740 |
|
|
"set msg \"wrong # args: should be \\\"source fileName\\\"\"\n"
|
1741 |
|
|
"Log $slave \"$msg ($args)\"\n"
|
1742 |
|
|
"return -code error $msg\n"
|
1743 |
|
|
"}\n"
|
1744 |
|
|
"set file [lindex $args 0]\n"
|
1745 |
|
|
"if {[catch {set file [TranslatePath $slave $file]} msg]} {\n"
|
1746 |
|
|
"Log $slave $msg\n"
|
1747 |
|
|
"return -code error \"permission denied\"\n"
|
1748 |
|
|
"}\n"
|
1749 |
|
|
"if {[catch {FileInAccessPath $slave $file} msg]} {\n"
|
1750 |
|
|
"Log $slave $msg\n"
|
1751 |
|
|
"return -code error \"permission denied\"\n"
|
1752 |
|
|
"}\n"
|
1753 |
|
|
"if {[catch {CheckFileName $slave $file} msg]} {\n"
|
1754 |
|
|
"Log $slave \"$file:$msg\"\n"
|
1755 |
|
|
"return -code error $msg\n"
|
1756 |
|
|
"}\n"
|
1757 |
|
|
"if {[catch {::interp invokehidden $slave source $file} msg]} {\n"
|
1758 |
|
|
"Log $slave $msg\n"
|
1759 |
|
|
"return -code error \"script error\"\n"
|
1760 |
|
|
"}\n"
|
1761 |
|
|
"return $msg\n"
|
1762 |
|
|
"}\n"
|
1763 |
|
|
"proc AliasLoad {slave file args} {\n"
|
1764 |
|
|
"set argc [llength $args]\n"
|
1765 |
|
|
"if {$argc > 2} {\n"
|
1766 |
|
|
"set msg \"load error: too many arguments\"\n"
|
1767 |
|
|
"Log $slave \"$msg ($argc) {$file $args}\"\n"
|
1768 |
|
|
"return -code error $msg\n"
|
1769 |
|
|
"}\n"
|
1770 |
|
|
"set package [lindex $args 0]\n"
|
1771 |
|
|
"set target [lindex $args 1]\n"
|
1772 |
|
|
"if {[string length $target]} {\n"
|
1773 |
|
|
"if {![NestedOk $slave]} {\n"
|
1774 |
|
|
"Log $slave \"loading to a sub interp (nestedok)\\\n"
|
1775 |
|
|
"\011\011\011disabled (trying to load $package to $target)\"\n"
|
1776 |
|
|
"return -code error \"permission denied (nested load)\"\n"
|
1777 |
|
|
"}\n"
|
1778 |
|
|
"}\n"
|
1779 |
|
|
"if {[string length $file] == 0} {\n"
|
1780 |
|
|
"if {[string length $package] == 0} {\n"
|
1781 |
|
|
"set msg \"load error: empty filename and no package name\"\n"
|
1782 |
|
|
"Log $slave $msg\n"
|
1783 |
|
|
"return -code error $msg\n"
|
1784 |
|
|
"}\n"
|
1785 |
|
|
"if {![StaticsOk $slave]} {\n"
|
1786 |
|
|
"Log $slave \"static packages loading disabled\\\n"
|
1787 |
|
|
"\011\011\011(trying to load $package to $target)\"\n"
|
1788 |
|
|
"return -code error \"permission denied (static package)\"\n"
|
1789 |
|
|
"}\n"
|
1790 |
|
|
"} else {\n"
|
1791 |
|
|
"if {[catch {set file [TranslatePath $slave $file]} msg]} {\n"
|
1792 |
|
|
"Log $slave $msg\n"
|
1793 |
|
|
"return -code error \"permission denied\"\n"
|
1794 |
|
|
"}\n"
|
1795 |
|
|
"if {[catch {FileInAccessPath $slave $file} msg]} {\n"
|
1796 |
|
|
"Log $slave $msg\n"
|
1797 |
|
|
"return -code error \"permission denied (path)\"\n"
|
1798 |
|
|
"}\n"
|
1799 |
|
|
"}\n"
|
1800 |
|
|
"if {[catch {::interp invokehidden\\\n"
|
1801 |
|
|
"\011\011$slave load $file $package $target} msg]} {\n"
|
1802 |
|
|
"Log $slave $msg\n"
|
1803 |
|
|
"return -code error $msg\n"
|
1804 |
|
|
"}\n"
|
1805 |
|
|
"return $msg\n"
|
1806 |
|
|
"}\n"
|
1807 |
|
|
"proc FileInAccessPath {slave file} {\n"
|
1808 |
|
|
"set access_path [GetAccessPath $slave]\n"
|
1809 |
|
|
"if {[file isdirectory $file]} {\n"
|
1810 |
|
|
"error \"\\\"$file\\\": is a directory\"\n"
|
1811 |
|
|
"}\n"
|
1812 |
|
|
"set parent [file dirname $file]\n"
|
1813 |
|
|
"if {[lsearch -exact $access_path $parent] == -1} {\n"
|
1814 |
|
|
"error \"\\\"$file\\\": not in access_path\"\n"
|
1815 |
|
|
"}\n"
|
1816 |
|
|
"}\n"
|
1817 |
|
|
"proc Subset {slave command okpat args} {\n"
|
1818 |
|
|
"set subcommand [lindex $args 0]\n"
|
1819 |
|
|
"if {[regexp $okpat $subcommand]} {\n"
|
1820 |
|
|
"return [eval {$command $subcommand} [lrange $args 1 end]]\n"
|
1821 |
|
|
"}\n"
|
1822 |
|
|
"set msg \"not allowed to invoke subcommand $subcommand of $command\"\n"
|
1823 |
|
|
"Log $slave $msg\n"
|
1824 |
|
|
"error $msg\n"
|
1825 |
|
|
"}\n"
|
1826 |
|
|
"proc AliasSubset {slave alias target args} {\n"
|
1827 |
|
|
"set pat ^(; set sep \"\"\n"
|
1828 |
|
|
"foreach sub $args {\n"
|
1829 |
|
|
"append pat $sep$sub\n"
|
1830 |
|
|
"set sep |\n"
|
1831 |
|
|
"}\n"
|
1832 |
|
|
"append pat )\\$\n"
|
1833 |
|
|
"::interp alias $slave $alias {}\\\n"
|
1834 |
|
|
"\011\011[namespace current]::Subset $slave $target $pat\n"
|
1835 |
|
|
"}\n"
|
1836 |
|
|
"proc AliasEncoding {slave args} {\n"
|
1837 |
|
|
"set argc [llength $args]\n"
|
1838 |
|
|
"set okpat \"^(name.*|convert.*)\\$\"\n"
|
1839 |
|
|
"set subcommand [lindex $args 0]\n"
|
1840 |
|
|
"if {[regexp $okpat $subcommand]} {\n"
|
1841 |
|
|
"return [eval ::interp invokehidden $slave encoding $subcommand \\\n"
|
1842 |
|
|
"\011\011 [lrange $args 1 end]]\n"
|
1843 |
|
|
"}\n"
|
1844 |
|
|
"if {[string match $subcommand system]} {\n"
|
1845 |
|
|
"if {$argc == 1} {\n"
|
1846 |
|
|
"if {[catch {::interp invokehidden \\\n"
|
1847 |
|
|
"\011\011\011$slave encoding system} msg]} {\n"
|
1848 |
|
|
"Log $slave $msg\n"
|
1849 |
|
|
"return -code error \"script error\"\n"
|
1850 |
|
|
"}\n"
|
1851 |
|
|
"} else {\n"
|
1852 |
|
|
"set msg \"wrong # args: should be \\\"encoding system\\\"\"\n"
|
1853 |
|
|
"Log $slave $msg\n"
|
1854 |
|
|
"error $msg\n"
|
1855 |
|
|
"}\n"
|
1856 |
|
|
"} else {\n"
|
1857 |
|
|
"set msg \"wrong # args: should be \\\"encoding option ?arg ...?\\\"\"\n"
|
1858 |
|
|
"Log $slave $msg\n"
|
1859 |
|
|
"error $msg\n"
|
1860 |
|
|
"}\n"
|
1861 |
|
|
"return $msg\n"
|
1862 |
|
|
"}\n"
|
1863 |
|
|
"}\n"
|
1864 |
|
|
;
|
1865 |
|
|
static char Et_zFile6[] =
|
1866 |
|
|
"# Tcl autoload index file, version 2.0\n"
|
1867 |
|
|
"# This file is generated by the \"auto_mkindex\" command\n"
|
1868 |
|
|
"# and sourced to set up indexing information for one or\n"
|
1869 |
|
|
"# more commands. Typically each line is a command that\n"
|
1870 |
|
|
"# sets an element in the auto_index array, where the\n"
|
1871 |
|
|
"# element name is the name of a command and the value is\n"
|
1872 |
|
|
"# a script that loads the command.\n"
|
1873 |
|
|
"\n"
|
1874 |
|
|
"set auto_index(auto_reset) [list source [file join $dir auto.tcl]]\n"
|
1875 |
|
|
"set auto_index(tcl_findLibrary) [list source [file join $dir auto.tcl]]\n"
|
1876 |
|
|
"set auto_index(auto_mkindex) [list source [file join $dir auto.tcl]]\n"
|
1877 |
|
|
"set auto_index(auto_mkindex_old) [list source [file join $dir auto.tcl]]\n"
|
1878 |
|
|
"set auto_index(::auto_mkindex_parser::init) [list source [file join $dir auto.tcl]]\n"
|
1879 |
|
|
"set auto_index(::auto_mkindex_parser::cleanup) [list source [file join $dir auto.tcl]]\n"
|
1880 |
|
|
"set auto_index(::auto_mkindex_parser::mkindex) [list source [file join $dir auto.tcl]]\n"
|
1881 |
|
|
"set auto_index(::auto_mkindex_parser::hook) [list source [file join $dir auto.tcl]]\n"
|
1882 |
|
|
"set auto_index(::auto_mkindex_parser::slavehook) [list source [file join $dir auto.tcl]]\n"
|
1883 |
|
|
"set auto_index(::auto_mkindex_parser::command) [list source [file join $dir auto.tcl]]\n"
|
1884 |
|
|
"set auto_index(::auto_mkindex_parser::commandInit) [list source [file join $dir auto.tcl]]\n"
|
1885 |
|
|
"set auto_index(::auto_mkindex_parser::fullname) [list source [file join $dir auto.tcl]]\n"
|
1886 |
|
|
"set auto_index(history) [list source [file join $dir history.tcl]]\n"
|
1887 |
|
|
"set auto_index(::tcl::HistAdd) [list source [file join $dir history.tcl]]\n"
|
1888 |
|
|
"set auto_index(::tcl::HistKeep) [list source [file join $dir history.tcl]]\n"
|
1889 |
|
|
"set auto_index(::tcl::HistClear) [list source [file join $dir history.tcl]]\n"
|
1890 |
|
|
"set auto_index(::tcl::HistInfo) [list source [file join $dir history.tcl]]\n"
|
1891 |
|
|
"set auto_index(::tcl::HistRedo) [list source [file join $dir history.tcl]]\n"
|
1892 |
|
|
"set auto_index(::tcl::HistIndex) [list source [file join $dir history.tcl]]\n"
|
1893 |
|
|
"set auto_index(::tcl::HistEvent) [list source [file join $dir history.tcl]]\n"
|
1894 |
|
|
"set auto_index(::tcl::HistChange) [list source [file join $dir history.tcl]]\n"
|
1895 |
|
|
"set auto_index(tclLdAout) [list source [file join $dir ldAout.tcl]]\n"
|
1896 |
|
|
"set auto_index(pkg_compareExtension) [list source [file join $dir package.tcl]]\n"
|
1897 |
|
|
"set auto_index(pkg_mkIndex) [list source [file join $dir package.tcl]]\n"
|
1898 |
|
|
"set auto_index(tclPkgSetup) [list source [file join $dir package.tcl]]\n"
|
1899 |
|
|
"set auto_index(tclMacPkgSearch) [list source [file join $dir package.tcl]]\n"
|
1900 |
|
|
"set auto_index(tclPkgUnknown) [list source [file join $dir package.tcl]]\n"
|
1901 |
|
|
"set auto_index(::pkg::create) [list source [file join $dir package.tcl]]\n"
|
1902 |
|
|
"set auto_index(parray) [list source [file join $dir parray.tcl]]\n"
|
1903 |
|
|
"set auto_index(::safe::InterpStatics) [list source [file join $dir safe.tcl]]\n"
|
1904 |
|
|
"set auto_index(::safe::InterpNested) [list source [file join $dir safe.tcl]]\n"
|
1905 |
|
|
"set auto_index(::safe::interpCreate) [list source [file join $dir safe.tcl]]\n"
|
1906 |
|
|
"set auto_index(::safe::interpInit) [list source [file join $dir safe.tcl]]\n"
|
1907 |
|
|
"set auto_index(::safe::CheckInterp) [list source [file join $dir safe.tcl]]\n"
|
1908 |
|
|
"set auto_index(::safe::interpConfigure) [list source [file join $dir safe.tcl]]\n"
|
1909 |
|
|
"set auto_index(::safe::InterpCreate) [list source [file join $dir safe.tcl]]\n"
|
1910 |
|
|
"set auto_index(::safe::InterpSetConfig) [list source [file join $dir safe.tcl]]\n"
|
1911 |
|
|
"set auto_index(::safe::interpFindInAccessPath) [list source [file join $dir safe.tcl]]\n"
|
1912 |
|
|
"set auto_index(::safe::interpAddToAccessPath) [list source [file join $dir safe.tcl]]\n"
|
1913 |
|
|
"set auto_index(::safe::InterpInit) [list source [file join $dir safe.tcl]]\n"
|
1914 |
|
|
"set auto_index(::safe::AddSubDirs) [list source [file join $dir safe.tcl]]\n"
|
1915 |
|
|
"set auto_index(::safe::interpDelete) [list source [file join $dir safe.tcl]]\n"
|
1916 |
|
|
"set auto_index(::safe::setLogCmd) [list source [file join $dir safe.tcl]]\n"
|
1917 |
|
|
"set auto_index(::safe::SyncAccessPath) [list source [file join $dir safe.tcl]]\n"
|
1918 |
|
|
"set auto_index(::safe::InterpStateName) [list source [file join $dir safe.tcl]]\n"
|
1919 |
|
|
"set auto_index(::safe::IsInterp) [list source [file join $dir safe.tcl]]\n"
|
1920 |
|
|
"set auto_index(::safe::PathToken) [list source [file join $dir safe.tcl]]\n"
|
1921 |
|
|
"set auto_index(::safe::PathListName) [list source [file join $dir safe.tcl]]\n"
|
1922 |
|
|
"set auto_index(::safe::VirtualPathListName) [list source [file join $dir safe.tcl]]\n"
|
1923 |
|
|
"set auto_index(::safe::PathNumberName) [list source [file join $dir safe.tcl]]\n"
|
1924 |
|
|
"set auto_index(::safe::StaticsOkName) [list source [file join $dir safe.tcl]]\n"
|
1925 |
|
|
"set auto_index(::safe::NestedOkName) [list source [file join $dir safe.tcl]]\n"
|
1926 |
|
|
"set auto_index(::safe::Toplevel) [list source [file join $dir safe.tcl]]\n"
|
1927 |
|
|
"set auto_index(::safe::Set) [list source [file join $dir safe.tcl]]\n"
|
1928 |
|
|
"set auto_index(::safe::Lappend) [list source [file join $dir safe.tcl]]\n"
|
1929 |
|
|
"set auto_index(::safe::Unset) [list source [file join $dir safe.tcl]]\n"
|
1930 |
|
|
"set auto_index(::safe::Exists) [list source [file join $dir safe.tcl]]\n"
|
1931 |
|
|
"set auto_index(::safe::GetAccessPath) [list source [file join $dir safe.tcl]]\n"
|
1932 |
|
|
"set auto_index(::safe::StaticsOk) [list source [file join $dir safe.tcl]]\n"
|
1933 |
|
|
"set auto_index(::safe::NestedOk) [list source [file join $dir safe.tcl]]\n"
|
1934 |
|
|
"set auto_index(::safe::DeleteHookName) [list source [file join $dir safe.tcl]]\n"
|
1935 |
|
|
"set auto_index(::safe::TranslatePath) [list source [file join $dir safe.tcl]]\n"
|
1936 |
|
|
"set auto_index(::safe::Log) [list source [file join $dir safe.tcl]]\n"
|
1937 |
|
|
"set auto_index(::safe::CheckFileName) [list source [file join $dir safe.tcl]]\n"
|
1938 |
|
|
"set auto_index(::safe::AliasSource) [list source [file join $dir safe.tcl]]\n"
|
1939 |
|
|
"set auto_index(::safe::AliasLoad) [list source [file join $dir safe.tcl]]\n"
|
1940 |
|
|
"set auto_index(::safe::FileInAccessPath) [list source [file join $dir safe.tcl]]\n"
|
1941 |
|
|
"set auto_index(::safe::Subset) [list source [file join $dir safe.tcl]]\n"
|
1942 |
|
|
"set auto_index(::safe::AliasSubset) [list source [file join $dir safe.tcl]]\n"
|
1943 |
|
|
"set auto_index(tcl_wordBreakAfter) [list source [file join $dir word.tcl]]\n"
|
1944 |
|
|
"set auto_index(tcl_wordBreakBefore) [list source [file join $dir word.tcl]]\n"
|
1945 |
|
|
"set auto_index(tcl_endOfWord) [list source [file join $dir word.tcl]]\n"
|
1946 |
|
|
"set auto_index(tcl_startOfNextWord) [list source [file join $dir word.tcl]]\n"
|
1947 |
|
|
"set auto_index(tcl_startOfPreviousWord) [list source [file join $dir word.tcl]]\n"
|
1948 |
|
|
;
|
1949 |
|
|
static char Et_zFile7[] =
|
1950 |
|
|
"if {[string equal $tcl_platform(platform) \"windows\"]} {\n"
|
1951 |
|
|
"set tcl_wordchars \"\\\\S\"\n"
|
1952 |
|
|
"set tcl_nonwordchars \"\\\\s\"\n"
|
1953 |
|
|
"} else {\n"
|
1954 |
|
|
"set tcl_wordchars \"\\\\w\"\n"
|
1955 |
|
|
"set tcl_nonwordchars \"\\\\W\"\n"
|
1956 |
|
|
"}\n"
|
1957 |
|
|
"proc tcl_wordBreakAfter {str start} {\n"
|
1958 |
|
|
"global tcl_nonwordchars tcl_wordchars\n"
|
1959 |
|
|
"set str [string range $str $start end]\n"
|
1960 |
|
|
"if {[regexp -indices \"$tcl_wordchars$tcl_nonwordchars|$tcl_nonwordchars$tcl_wordchars\" $str result]} {\n"
|
1961 |
|
|
"return [expr {[lindex $result 1] + $start}]\n"
|
1962 |
|
|
"}\n"
|
1963 |
|
|
"return -1\n"
|
1964 |
|
|
"}\n"
|
1965 |
|
|
"proc tcl_wordBreakBefore {str start} {\n"
|
1966 |
|
|
"global tcl_nonwordchars tcl_wordchars\n"
|
1967 |
|
|
"if {[string equal $start end]} {\n"
|
1968 |
|
|
"set start [string length $str]\n"
|
1969 |
|
|
"}\n"
|
1970 |
|
|
"if {[regexp -indices \"^.*($tcl_wordchars$tcl_nonwordchars|$tcl_nonwordchars$tcl_wordchars)\" [string range $str 0 $start] result]} {\n"
|
1971 |
|
|
"return [lindex $result 1]\n"
|
1972 |
|
|
"}\n"
|
1973 |
|
|
"return -1\n"
|
1974 |
|
|
"}\n"
|
1975 |
|
|
"proc tcl_endOfWord {str start} {\n"
|
1976 |
|
|
"global tcl_nonwordchars tcl_wordchars\n"
|
1977 |
|
|
"if {[regexp -indices \"$tcl_nonwordchars*$tcl_wordchars+$tcl_nonwordchars\" \\\n"
|
1978 |
|
|
"\011 [string range $str $start end] result]} {\n"
|
1979 |
|
|
"return [expr {[lindex $result 1] + $start}]\n"
|
1980 |
|
|
"}\n"
|
1981 |
|
|
"return -1\n"
|
1982 |
|
|
"}\n"
|
1983 |
|
|
"proc tcl_startOfNextWord {str start} {\n"
|
1984 |
|
|
"global tcl_nonwordchars tcl_wordchars\n"
|
1985 |
|
|
"if {[regexp -indices \"$tcl_wordchars*$tcl_nonwordchars+$tcl_wordchars\" \\\n"
|
1986 |
|
|
"\011 [string range $str $start end] result]} {\n"
|
1987 |
|
|
"return [expr {[lindex $result 1] + $start}]\n"
|
1988 |
|
|
"}\n"
|
1989 |
|
|
"return -1\n"
|
1990 |
|
|
"}\n"
|
1991 |
|
|
"proc tcl_startOfPreviousWord {str start} {\n"
|
1992 |
|
|
"global tcl_nonwordchars tcl_wordchars\n"
|
1993 |
|
|
"if {[string equal $start end]} {\n"
|
1994 |
|
|
"set start [string length $str]\n"
|
1995 |
|
|
"}\n"
|
1996 |
|
|
"if {[regexp -indices \\\n"
|
1997 |
|
|
"\011 \"$tcl_nonwordchars*($tcl_wordchars+)$tcl_nonwordchars*\\$\" \\\n"
|
1998 |
|
|
"\011 [string range $str 0 [expr {$start - 1}]] result word]} {\n"
|
1999 |
|
|
"return [lindex $word 0]\n"
|
2000 |
|
|
"}\n"
|
2001 |
|
|
"return -1\n"
|
2002 |
|
|
"}\n"
|
2003 |
|
|
;
|
2004 |
|
|
static char Et_zFile8[] =
|
2005 |
|
|
"proc bgerror err {\n"
|
2006 |
|
|
"global errorInfo tcl_platform\n"
|
2007 |
|
|
"set info $errorInfo ;\n"
|
2008 |
|
|
"set ret [catch {tkerror $err} msg];\n"
|
2009 |
|
|
"if {$ret != 1} {return -code $ret $msg}\n"
|
2010 |
|
|
"if {$tcl_platform(platform) == \"macintosh\"} {\n"
|
2011 |
|
|
"set ok Ok\n"
|
2012 |
|
|
"} else {\n"
|
2013 |
|
|
"set ok OK\n"
|
2014 |
|
|
"}\n"
|
2015 |
|
|
"set button [tk_dialog .bgerrorDialog \"Error in Tcl Script\" \\\n"
|
2016 |
|
|
"\011 \"Error: $err\" error 0 $ok \"Skip Messages\" \"Stack Trace\"]\n"
|
2017 |
|
|
"if {$button == 0} {\n"
|
2018 |
|
|
"return\n"
|
2019 |
|
|
"} elseif {$button == 1} {\n"
|
2020 |
|
|
"return -code break\n"
|
2021 |
|
|
"}\n"
|
2022 |
|
|
"set w .bgerrorTrace\n"
|
2023 |
|
|
"catch {destroy $w}\n"
|
2024 |
|
|
"toplevel $w -class ErrorTrace\n"
|
2025 |
|
|
"wm minsize $w 1 1\n"
|
2026 |
|
|
"wm title $w \"Stack Trace for Error\"\n"
|
2027 |
|
|
"wm iconname $w \"Stack Trace\"\n"
|
2028 |
|
|
"button $w.ok -text OK -command \"destroy $w\" -default active\n"
|
2029 |
|
|
"if {![string compare $tcl_platform(platform) \"macintosh\"]} {\n"
|
2030 |
|
|
"text $w.text -relief flat -bd 2 -highlightthickness 0 -setgrid true \\\n"
|
2031 |
|
|
"\011 -yscrollcommand \"$w.scroll set\" -width 60 -height 20\n"
|
2032 |
|
|
"} else {\n"
|
2033 |
|
|
"text $w.text -relief sunken -bd 2 -yscrollcommand \"$w.scroll set\" \\\n"
|
2034 |
|
|
"\011 -setgrid true -width 60 -height 20\n"
|
2035 |
|
|
"}\n"
|
2036 |
|
|
"scrollbar $w.scroll -relief sunken -command \"$w.text yview\"\n"
|
2037 |
|
|
"pack $w.ok -side bottom -padx 3m -pady 2m\n"
|
2038 |
|
|
"pack $w.scroll -side right -fill y\n"
|
2039 |
|
|
"pack $w.text -side left -expand yes -fill both\n"
|
2040 |
|
|
"$w.text insert 0.0 $info\n"
|
2041 |
|
|
"$w.text mark set insert 0.0\n"
|
2042 |
|
|
"bind $w <Return> \"destroy $w\"\n"
|
2043 |
|
|
"bind $w.text <Return> \"destroy $w; break\"\n"
|
2044 |
|
|
"wm withdraw $w\n"
|
2045 |
|
|
"update idletasks\n"
|
2046 |
|
|
"set x [expr {[winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \\\n"
|
2047 |
|
|
"\011 - [winfo vrootx [winfo parent $w]]}]\n"
|
2048 |
|
|
"set y [expr {[winfo screenheight $w]/2 - [winfo reqheight $w]/2 \\\n"
|
2049 |
|
|
"\011 - [winfo vrooty [winfo parent $w]]}]\n"
|
2050 |
|
|
"wm geom $w +$x+$y\n"
|
2051 |
|
|
"wm deiconify $w\n"
|
2052 |
|
|
"if {[string compare [grab current .] \"\"]} {\n"
|
2053 |
|
|
"grab release [grab current .]\n"
|
2054 |
|
|
"}\n"
|
2055 |
|
|
"}\n"
|
2056 |
|
|
;
|
2057 |
|
|
static char Et_zFile9[] =
|
2058 |
|
|
"if {[string match \"macintosh\" $tcl_platform(platform)]} {\n"
|
2059 |
|
|
"bind Radiobutton <Enter> {\n"
|
2060 |
|
|
"tkButtonEnter %W\n"
|
2061 |
|
|
"}\n"
|
2062 |
|
|
"bind Radiobutton <1> {\n"
|
2063 |
|
|
"tkButtonDown %W\n"
|
2064 |
|
|
"}\n"
|
2065 |
|
|
"bind Radiobutton <ButtonRelease-1> {\n"
|
2066 |
|
|
"tkButtonUp %W\n"
|
2067 |
|
|
"}\n"
|
2068 |
|
|
"bind Checkbutton <Enter> {\n"
|
2069 |
|
|
"tkButtonEnter %W\n"
|
2070 |
|
|
"}\n"
|
2071 |
|
|
"bind Checkbutton <1> {\n"
|
2072 |
|
|
"tkButtonDown %W\n"
|
2073 |
|
|
"}\n"
|
2074 |
|
|
"bind Checkbutton <ButtonRelease-1> {\n"
|
2075 |
|
|
"tkButtonUp %W\n"
|
2076 |
|
|
"}\n"
|
2077 |
|
|
"}\n"
|
2078 |
|
|
"if {[string match \"windows\" $tcl_platform(platform)]} {\n"
|
2079 |
|
|
"bind Checkbutton <equal> {\n"
|
2080 |
|
|
"tkCheckRadioInvoke %W select\n"
|
2081 |
|
|
"}\n"
|
2082 |
|
|
"bind Checkbutton <plus> {\n"
|
2083 |
|
|
"tkCheckRadioInvoke %W select\n"
|
2084 |
|
|
"}\n"
|
2085 |
|
|
"bind Checkbutton <minus> {\n"
|
2086 |
|
|
"tkCheckRadioInvoke %W deselect\n"
|
2087 |
|
|
"}\n"
|
2088 |
|
|
"bind Checkbutton <1> {\n"
|
2089 |
|
|
"tkCheckRadioDown %W\n"
|
2090 |
|
|
"}\n"
|
2091 |
|
|
"bind Checkbutton <ButtonRelease-1> {\n"
|
2092 |
|
|
"tkButtonUp %W\n"
|
2093 |
|
|
"}\n"
|
2094 |
|
|
"bind Checkbutton <Enter> {\n"
|
2095 |
|
|
"tkCheckRadioEnter %W\n"
|
2096 |
|
|
"}\n"
|
2097 |
|
|
"bind Radiobutton <1> {\n"
|
2098 |
|
|
"tkCheckRadioDown %W\n"
|
2099 |
|
|
"}\n"
|
2100 |
|
|
"bind Radiobutton <ButtonRelease-1> {\n"
|
2101 |
|
|
"tkButtonUp %W\n"
|
2102 |
|
|
"}\n"
|
2103 |
|
|
"bind Radiobutton <Enter> {\n"
|
2104 |
|
|
"tkCheckRadioEnter %W\n"
|
2105 |
|
|
"}\n"
|
2106 |
|
|
"}\n"
|
2107 |
|
|
"if {[string match \"unix\" $tcl_platform(platform)]} {\n"
|
2108 |
|
|
"bind Checkbutton <Return> {\n"
|
2109 |
|
|
"if {!$tk_strictMotif} {\n"
|
2110 |
|
|
"tkCheckRadioInvoke %W\n"
|
2111 |
|
|
"}\n"
|
2112 |
|
|
"}\n"
|
2113 |
|
|
"bind Radiobutton <Return> {\n"
|
2114 |
|
|
"if {!$tk_strictMotif} {\n"
|
2115 |
|
|
"tkCheckRadioInvoke %W\n"
|
2116 |
|
|
"}\n"
|
2117 |
|
|
"}\n"
|
2118 |
|
|
"bind Checkbutton <1> {\n"
|
2119 |
|
|
"tkCheckRadioInvoke %W\n"
|
2120 |
|
|
"}\n"
|
2121 |
|
|
"bind Radiobutton <1> {\n"
|
2122 |
|
|
"tkCheckRadioInvoke %W\n"
|
2123 |
|
|
"}\n"
|
2124 |
|
|
"bind Checkbutton <Enter> {\n"
|
2125 |
|
|
"tkButtonEnter %W\n"
|
2126 |
|
|
"}\n"
|
2127 |
|
|
"bind Radiobutton <Enter> {\n"
|
2128 |
|
|
"tkButtonEnter %W\n"
|
2129 |
|
|
"}\n"
|
2130 |
|
|
"}\n"
|
2131 |
|
|
"bind Button <space> {\n"
|
2132 |
|
|
"tkButtonInvoke %W\n"
|
2133 |
|
|
"}\n"
|
2134 |
|
|
"bind Checkbutton <space> {\n"
|
2135 |
|
|
"tkCheckRadioInvoke %W\n"
|
2136 |
|
|
"}\n"
|
2137 |
|
|
"bind Radiobutton <space> {\n"
|
2138 |
|
|
"tkCheckRadioInvoke %W\n"
|
2139 |
|
|
"}\n"
|
2140 |
|
|
"bind Button <FocusIn> {}\n"
|
2141 |
|
|
"bind Button <Enter> {\n"
|
2142 |
|
|
"tkButtonEnter %W\n"
|
2143 |
|
|
"}\n"
|
2144 |
|
|
"bind Button <Leave> {\n"
|
2145 |
|
|
"tkButtonLeave %W\n"
|
2146 |
|
|
"}\n"
|
2147 |
|
|
"bind Button <1> {\n"
|
2148 |
|
|
"tkButtonDown %W\n"
|
2149 |
|
|
"}\n"
|
2150 |
|
|
"bind Button <ButtonRelease-1> {\n"
|
2151 |
|
|
"tkButtonUp %W\n"
|
2152 |
|
|
"}\n"
|
2153 |
|
|
"bind Checkbutton <FocusIn> {}\n"
|
2154 |
|
|
"bind Checkbutton <Leave> {\n"
|
2155 |
|
|
"tkButtonLeave %W\n"
|
2156 |
|
|
"}\n"
|
2157 |
|
|
"bind Radiobutton <FocusIn> {}\n"
|
2158 |
|
|
"bind Radiobutton <Leave> {\n"
|
2159 |
|
|
"tkButtonLeave %W\n"
|
2160 |
|
|
"}\n"
|
2161 |
|
|
"if {[string match \"windows\" $tcl_platform(platform)]} {\n"
|
2162 |
|
|
"proc tkButtonEnter w {\n"
|
2163 |
|
|
"global tkPriv\n"
|
2164 |
|
|
"if {[string compare [$w cget -state] \"disabled\"] \\\n"
|
2165 |
|
|
"\011 && [string equal $tkPriv(buttonWindow) $w]} {\n"
|
2166 |
|
|
"$w configure -state active -relief sunken\n"
|
2167 |
|
|
"}\n"
|
2168 |
|
|
"set tkPriv(window) $w\n"
|
2169 |
|
|
"}\n"
|
2170 |
|
|
"proc tkButtonLeave w {\n"
|
2171 |
|
|
"global tkPriv\n"
|
2172 |
|
|
"if {[string compare [$w cget -state] \"disabled\"]} {\n"
|
2173 |
|
|
"$w configure -state normal\n"
|
2174 |
|
|
"}\n"
|
2175 |
|
|
"if {[string equal $tkPriv(buttonWindow) $w]} {\n"
|
2176 |
|
|
"$w configure -relief $tkPriv(relief)\n"
|
2177 |
|
|
"}\n"
|
2178 |
|
|
"set tkPriv(window) \"\"\n"
|
2179 |
|
|
"}\n"
|
2180 |
|
|
"proc tkCheckRadioEnter w {\n"
|
2181 |
|
|
"global tkPriv\n"
|
2182 |
|
|
"if {[string compare [$w cget -state] \"disabled\"] \\\n"
|
2183 |
|
|
"\011 && [string equal $tkPriv(buttonWindow) $w]} {\n"
|
2184 |
|
|
"$w configure -state active\n"
|
2185 |
|
|
"}\n"
|
2186 |
|
|
"set tkPriv(window) $w\n"
|
2187 |
|
|
"}\n"
|
2188 |
|
|
"proc tkButtonDown w {\n"
|
2189 |
|
|
"global tkPriv\n"
|
2190 |
|
|
"set tkPriv(relief) [$w cget -relief]\n"
|
2191 |
|
|
"if {[string compare [$w cget -state] \"disabled\"]} {\n"
|
2192 |
|
|
"set tkPriv(buttonWindow) $w\n"
|
2193 |
|
|
"$w configure -relief sunken -state active\n"
|
2194 |
|
|
"}\n"
|
2195 |
|
|
"}\n"
|
2196 |
|
|
"proc tkCheckRadioDown w {\n"
|
2197 |
|
|
"global tkPriv\n"
|
2198 |
|
|
"set tkPriv(relief) [$w cget -relief]\n"
|
2199 |
|
|
"if {[string compare [$w cget -state] \"disabled\"]} {\n"
|
2200 |
|
|
"set tkPriv(buttonWindow) $w\n"
|
2201 |
|
|
"$w configure -state active\n"
|
2202 |
|
|
"}\n"
|
2203 |
|
|
"}\n"
|
2204 |
|
|
"proc tkButtonUp w {\n"
|
2205 |
|
|
"global tkPriv\n"
|
2206 |
|
|
"if {[string equal $tkPriv(buttonWindow) $w]} {\n"
|
2207 |
|
|
"set tkPriv(buttonWindow) \"\"\n"
|
2208 |
|
|
"$w configure -relief $tkPriv(relief)\n"
|
2209 |
|
|
"if {[string equal $tkPriv(window) $w]\n"
|
2210 |
|
|
"&& [string compare [$w cget -state] \"disabled\"]} {\n"
|
2211 |
|
|
"$w configure -state normal\n"
|
2212 |
|
|
"uplevel #0 [list $w invoke]\n"
|
2213 |
|
|
"}\n"
|
2214 |
|
|
"}\n"
|
2215 |
|
|
"}\n"
|
2216 |
|
|
"}\n"
|
2217 |
|
|
"if {[string match \"unix\" $tcl_platform(platform)]} {\n"
|
2218 |
|
|
"proc tkButtonEnter {w} {\n"
|
2219 |
|
|
"global tkPriv\n"
|
2220 |
|
|
"if {[string compare [$w cget -state] \"disabled\"]} {\n"
|
2221 |
|
|
"$w configure -state active\n"
|
2222 |
|
|
"if {[string equal $tkPriv(buttonWindow) $w]} {\n"
|
2223 |
|
|
"$w configure -state active -relief sunken\n"
|
2224 |
|
|
"}\n"
|
2225 |
|
|
"}\n"
|
2226 |
|
|
"set tkPriv(window) $w\n"
|
2227 |
|
|
"}\n"
|
2228 |
|
|
"proc tkButtonLeave w {\n"
|
2229 |
|
|
"global tkPriv\n"
|
2230 |
|
|
"if {[string compare [$w cget -state] \"disabled\"]} {\n"
|
2231 |
|
|
"$w configure -state normal\n"
|
2232 |
|
|
"}\n"
|
2233 |
|
|
"if {[string equal $tkPriv(buttonWindow) $w]} {\n"
|
2234 |
|
|
"$w configure -relief $tkPriv(relief)\n"
|
2235 |
|
|
"}\n"
|
2236 |
|
|
"set tkPriv(window) \"\"\n"
|
2237 |
|
|
"}\n"
|
2238 |
|
|
"proc tkButtonDown w {\n"
|
2239 |
|
|
"global tkPriv\n"
|
2240 |
|
|
"set tkPriv(relief) [$w cget -relief]\n"
|
2241 |
|
|
"if {[string compare [$w cget -state] \"disabled\"]} {\n"
|
2242 |
|
|
"set tkPriv(buttonWindow) $w\n"
|
2243 |
|
|
"$w configure -relief sunken\n"
|
2244 |
|
|
"}\n"
|
2245 |
|
|
"}\n"
|
2246 |
|
|
"proc tkButtonUp w {\n"
|
2247 |
|
|
"global tkPriv\n"
|
2248 |
|
|
"if {[string equal $w $tkPriv(buttonWindow)]} {\n"
|
2249 |
|
|
"set tkPriv(buttonWindow) \"\"\n"
|
2250 |
|
|
"$w configure -relief $tkPriv(relief)\n"
|
2251 |
|
|
"if {[string equal $w $tkPriv(window)] \\\n"
|
2252 |
|
|
"\011\011&& [string compare [$w cget -state] \"disabled\"]} {\n"
|
2253 |
|
|
"uplevel #0 [list $w invoke]\n"
|
2254 |
|
|
"}\n"
|
2255 |
|
|
"}\n"
|
2256 |
|
|
"}\n"
|
2257 |
|
|
"}\n"
|
2258 |
|
|
"if {[string match \"macintosh\" $tcl_platform(platform)]} {\n"
|
2259 |
|
|
"proc tkButtonEnter {w} {\n"
|
2260 |
|
|
"global tkPriv\n"
|
2261 |
|
|
"if {[string compare [$w cget -state] \"disabled\"]} {\n"
|
2262 |
|
|
"if {[string equal $w $tkPriv(buttonWindow)]} {\n"
|
2263 |
|
|
"$w configure -state active\n"
|
2264 |
|
|
"}\n"
|
2265 |
|
|
"}\n"
|
2266 |
|
|
"set tkPriv(window) $w\n"
|
2267 |
|
|
"}\n"
|
2268 |
|
|
"proc tkButtonLeave w {\n"
|
2269 |
|
|
"global tkPriv\n"
|
2270 |
|
|
"if {[string equal $w $tkPriv(buttonWindow)]} {\n"
|
2271 |
|
|
"$w configure -state normal\n"
|
2272 |
|
|
"}\n"
|
2273 |
|
|
"set tkPriv(window) \"\"\n"
|
2274 |
|
|
"}\n"
|
2275 |
|
|
"proc tkButtonDown w {\n"
|
2276 |
|
|
"global tkPriv\n"
|
2277 |
|
|
"if {[string compare [$w cget -state] \"disabled\"]} {\n"
|
2278 |
|
|
"set tkPriv(buttonWindow) $w\n"
|
2279 |
|
|
"$w configure -state active\n"
|
2280 |
|
|
"}\n"
|
2281 |
|
|
"}\n"
|
2282 |
|
|
"proc tkButtonUp w {\n"
|
2283 |
|
|
"global tkPriv\n"
|
2284 |
|
|
"if {[string equal $w $tkPriv(buttonWindow)]} {\n"
|
2285 |
|
|
"$w configure -state normal\n"
|
2286 |
|
|
"set tkPriv(buttonWindow) \"\"\n"
|
2287 |
|
|
"if {[string equal $w $tkPriv(window)]\n"
|
2288 |
|
|
"&& [string compare [$w cget -state] \"disabled\"]} {\n"
|
2289 |
|
|
"uplevel #0 [list $w invoke]\n"
|
2290 |
|
|
"}\n"
|
2291 |
|
|
"}\n"
|
2292 |
|
|
"}\n"
|
2293 |
|
|
"}\n"
|
2294 |
|
|
"proc tkButtonInvoke w {\n"
|
2295 |
|
|
"if {[string compare [$w cget -state] \"disabled\"]} {\n"
|
2296 |
|
|
"set oldRelief [$w cget -relief]\n"
|
2297 |
|
|
"set oldState [$w cget -state]\n"
|
2298 |
|
|
"$w configure -state active -relief sunken\n"
|
2299 |
|
|
"update idletasks\n"
|
2300 |
|
|
"after 100\n"
|
2301 |
|
|
"$w configure -state $oldState -relief $oldRelief\n"
|
2302 |
|
|
"uplevel #0 [list $w invoke]\n"
|
2303 |
|
|
"}\n"
|
2304 |
|
|
"}\n"
|
2305 |
|
|
"proc tkCheckRadioInvoke {w {cmd invoke}} {\n"
|
2306 |
|
|
"if {[string compare [$w cget -state] \"disabled\"]} {\n"
|
2307 |
|
|
"uplevel #0 [list $w $cmd]\n"
|
2308 |
|
|
"}\n"
|
2309 |
|
|
"}\n"
|
2310 |
|
|
;
|
2311 |
|
|
static char Et_zFile10[] =
|
2312 |
|
|
"proc tkColorDialog {args} {\n"
|
2313 |
|
|
"global tkPriv\n"
|
2314 |
|
|
"set w .__tk__color\n"
|
2315 |
|
|
"upvar #0 $w data\n"
|
2316 |
|
|
"set data(lines,red,start) 0\n"
|
2317 |
|
|
"set data(lines,red,last) -1\n"
|
2318 |
|
|
"set data(lines,green,start) 0\n"
|
2319 |
|
|
"set data(lines,green,last) -1\n"
|
2320 |
|
|
"set data(lines,blue,start) 0\n"
|
2321 |
|
|
"set data(lines,blue,last) -1\n"
|
2322 |
|
|
"set data(NUM_COLORBARS) 8\n"
|
2323 |
|
|
"set data(BARS_WIDTH) 128\n"
|
2324 |
|
|
"set data(PLGN_HEIGHT) 10\n"
|
2325 |
|
|
"set data(PLGN_WIDTH) 10\n"
|
2326 |
|
|
"tkColorDialog_Config $w $args\n"
|
2327 |
|
|
"tkColorDialog_InitValues $w\n"
|
2328 |
|
|
"set sc [winfo screen $data(-parent)]\n"
|
2329 |
|
|
"set winExists [winfo exists $w]\n"
|
2330 |
|
|
"if {!$winExists || [string compare $sc [winfo screen $w]]} {\n"
|
2331 |
|
|
"if {$winExists} {\n"
|
2332 |
|
|
"destroy $w\n"
|
2333 |
|
|
"}\n"
|
2334 |
|
|
"toplevel $w -class tkColorDialog -screen $sc\n"
|
2335 |
|
|
"tkColorDialog_BuildDialog $w\n"
|
2336 |
|
|
"}\n"
|
2337 |
|
|
"wm transient $w $data(-parent)\n"
|
2338 |
|
|
"::tk::PlaceWindow $w widget $data(-parent)\n"
|
2339 |
|
|
"wm title $w $data(-title)\n"
|
2340 |
|
|
"::tk::SetFocusGrab $w $data(okBtn)\n"
|
2341 |
|
|
"vwait tkPriv(selectColor)\n"
|
2342 |
|
|
"::tk::RestoreFocusGrab $w $data(okBtn)\n"
|
2343 |
|
|
"unset data\n"
|
2344 |
|
|
"return $tkPriv(selectColor)\n"
|
2345 |
|
|
"}\n"
|
2346 |
|
|
"proc tkColorDialog_InitValues {w} {\n"
|
2347 |
|
|
"upvar #0 $w data\n"
|
2348 |
|
|
"set data(intensityIncr) [expr {256 / $data(NUM_COLORBARS)}]\n"
|
2349 |
|
|
"set data(colorbarWidth) \\\n"
|
2350 |
|
|
"\011 [expr {$data(BARS_WIDTH) / $data(NUM_COLORBARS)}]\n"
|
2351 |
|
|
"set data(indent) [expr {$data(PLGN_WIDTH) / 2}]\n"
|
2352 |
|
|
"set data(colorPad) 2\n"
|
2353 |
|
|
"set data(selPad) [expr {$data(PLGN_WIDTH) / 2}]\n"
|
2354 |
|
|
"set data(minX) $data(indent)\n"
|
2355 |
|
|
"set data(maxX) [expr {$data(BARS_WIDTH) + $data(indent)-1}]\n"
|
2356 |
|
|
"set data(canvasWidth) [expr {$data(BARS_WIDTH) + $data(PLGN_WIDTH)}]\n"
|
2357 |
|
|
"set data(selection) $data(-initialcolor)\n"
|
2358 |
|
|
"set data(finalColor) $data(-initialcolor)\n"
|
2359 |
|
|
"set rgb [winfo rgb . $data(selection)]\n"
|
2360 |
|
|
"set data(red,intensity) [expr {[lindex $rgb 0]/0x100}]\n"
|
2361 |
|
|
"set data(green,intensity) [expr {[lindex $rgb 1]/0x100}]\n"
|
2362 |
|
|
"set data(blue,intensity) [expr {[lindex $rgb 2]/0x100}]\n"
|
2363 |
|
|
"}\n"
|
2364 |
|
|
"proc tkColorDialog_Config {w argList} {\n"
|
2365 |
|
|
"global tkPriv\n"
|
2366 |
|
|
"upvar #0 $w data\n"
|
2367 |
|
|
"if {[info exists tkPriv(selectColor)] && \\\n"
|
2368 |
|
|
"\011 [string compare $tkPriv(selectColor) \"\"]} {\n"
|
2369 |
|
|
"set defaultColor $tkPriv(selectColor)\n"
|
2370 |
|
|
"} else {\n"
|
2371 |
|
|
"set defaultColor [. cget -background]\n"
|
2372 |
|
|
"}\n"
|
2373 |
|
|
"set specs [list \\\n"
|
2374 |
|
|
"\011 [list -initialcolor \"\" \"\" $defaultColor] \\\n"
|
2375 |
|
|
"\011 [list -parent \"\" \"\" \".\"] \\\n"
|
2376 |
|
|
"\011 [list -title \"\" \"\" \"Color\"] \\\n"
|
2377 |
|
|
"\011 ]\n"
|
2378 |
|
|
"tclParseConfigSpec $w $specs \"\" $argList\n"
|
2379 |
|
|
"if {[string equal $data(-title) \"\"]} {\n"
|
2380 |
|
|
"set data(-title) \" \"\n"
|
2381 |
|
|
"}\n"
|
2382 |
|
|
"if {[catch {winfo rgb . $data(-initialcolor)} err]} {\n"
|
2383 |
|
|
"error $err\n"
|
2384 |
|
|
"}\n"
|
2385 |
|
|
"if {![winfo exists $data(-parent)]} {\n"
|
2386 |
|
|
"error \"bad window path name \\\"$data(-parent)\\\"\"\n"
|
2387 |
|
|
"}\n"
|
2388 |
|
|
"}\n"
|
2389 |
|
|
"proc tkColorDialog_BuildDialog {w} {\n"
|
2390 |
|
|
"upvar #0 $w data\n"
|
2391 |
|
|
"set topFrame [frame $w.top -relief raised -bd 1]\n"
|
2392 |
|
|
"set stripsFrame [frame $topFrame.colorStrip]\n"
|
2393 |
|
|
"foreach c { Red Green Blue } {\n"
|
2394 |
|
|
"set color [string tolower $c]\n"
|
2395 |
|
|
"set f [frame $stripsFrame.$color]\n"
|
2396 |
|
|
"set box [frame $f.box]\n"
|
2397 |
|
|
"label $box.label -text $c: -width 6 -under 0 -anchor ne\n"
|
2398 |
|
|
"entry $box.entry -textvariable [format %s $w]($color,intensity) \\\n"
|
2399 |
|
|
"\011 -width 4\n"
|
2400 |
|
|
"pack $box.label -side left -fill y -padx 2 -pady 3\n"
|
2401 |
|
|
"pack $box.entry -side left -anchor n -pady 0\n"
|
2402 |
|
|
"pack $box -side left -fill both\n"
|
2403 |
|
|
"set height [expr \\\n"
|
2404 |
|
|
"\011 {[winfo reqheight $box.entry] - \\\n"
|
2405 |
|
|
"\011 2*([$box.entry cget -highlightthickness] + [$box.entry cget -bd])}]\n"
|
2406 |
|
|
"canvas $f.color -height $height\\\n"
|
2407 |
|
|
"\011 -width $data(BARS_WIDTH) -relief sunken -bd 2\n"
|
2408 |
|
|
"canvas $f.sel -height $data(PLGN_HEIGHT) \\\n"
|
2409 |
|
|
"\011 -width $data(canvasWidth) -highlightthickness 0\n"
|
2410 |
|
|
"pack $f.color -expand yes -fill both\n"
|
2411 |
|
|
"pack $f.sel -expand yes -fill both\n"
|
2412 |
|
|
"pack $f -side top -fill x -padx 0 -pady 2\n"
|
2413 |
|
|
"set data($color,entry) $box.entry\n"
|
2414 |
|
|
"set data($color,col) $f.color\n"
|
2415 |
|
|
"set data($color,sel) $f.sel\n"
|
2416 |
|
|
"bind $data($color,col) <Configure> \\\n"
|
2417 |
|
|
"\011 [list tkColorDialog_DrawColorScale $w $color 1]\n"
|
2418 |
|
|
"bind $data($color,col) <Enter> \\\n"
|
2419 |
|
|
"\011 [list tkColorDialog_EnterColorBar $w $color]\n"
|
2420 |
|
|
"bind $data($color,col) <Leave> \\\n"
|
2421 |
|
|
"\011 [list tkColorDialog_LeaveColorBar $w $color]\n"
|
2422 |
|
|
"bind $data($color,sel) <Enter> \\\n"
|
2423 |
|
|
"\011 [list tkColorDialog_EnterColorBar $w $color]\n"
|
2424 |
|
|
"bind $data($color,sel) <Leave> \\\n"
|
2425 |
|
|
"\011 [list tkColorDialog_LeaveColorBar $w $color]\n"
|
2426 |
|
|
"bind $box.entry <Return> [list tkColorDialog_HandleRGBEntry $w]\n"
|
2427 |
|
|
"}\n"
|
2428 |
|
|
"pack $stripsFrame -side left -fill both -padx 4 -pady 10\n"
|
2429 |
|
|
"set selFrame [frame $topFrame.sel]\n"
|
2430 |
|
|
"set lab [label $selFrame.lab -text \"Selection:\" -under 0 -anchor sw]\n"
|
2431 |
|
|
"set ent [entry $selFrame.ent -textvariable [format %s $w](selection) \\\n"
|
2432 |
|
|
"\011-width 16]\n"
|
2433 |
|
|
"set f1 [frame $selFrame.f1 -relief sunken -bd 2]\n"
|
2434 |
|
|
"set data(finalCanvas) [frame $f1.demo -bd 0 -width 100 -height 70]\n"
|
2435 |
|
|
"pack $lab $ent -side top -fill x -padx 4 -pady 2\n"
|
2436 |
|
|
"pack $f1 -expand yes -anchor nw -fill both -padx 6 -pady 10\n"
|
2437 |
|
|
"pack $data(finalCanvas) -expand yes -fill both\n"
|
2438 |
|
|
"bind $ent <Return> [list tkColorDialog_HandleSelEntry $w]\n"
|
2439 |
|
|
"pack $selFrame -side left -fill none -anchor nw\n"
|
2440 |
|
|
"pack $topFrame -side top -expand yes -fill both -anchor nw\n"
|
2441 |
|
|
"set botFrame [frame $w.bot -relief raised -bd 1]\n"
|
2442 |
|
|
"button $botFrame.ok -text OK -width 8 -under 0 \\\n"
|
2443 |
|
|
"\011-command [list tkColorDialog_OkCmd $w]\n"
|
2444 |
|
|
"button $botFrame.cancel -text Cancel -width 8 -under 0 \\\n"
|
2445 |
|
|
"\011-command [list tkColorDialog_CancelCmd $w]\n"
|
2446 |
|
|
"set data(okBtn) $botFrame.ok\n"
|
2447 |
|
|
"set data(cancelBtn) $botFrame.cancel\n"
|
2448 |
|
|
"pack $botFrame.ok $botFrame.cancel \\\n"
|
2449 |
|
|
"\011-padx 10 -pady 10 -expand yes -side left\n"
|
2450 |
|
|
"pack $botFrame -side bottom -fill x\n"
|
2451 |
|
|
"bind $w <Alt-r> [list focus $data(red,entry)]\n"
|
2452 |
|
|
"bind $w <Alt-g> [list focus $data(green,entry)]\n"
|
2453 |
|
|
"bind $w <Alt-b> [list focus $data(blue,entry)]\n"
|
2454 |
|
|
"bind $w <Alt-s> [list focus $ent]\n"
|
2455 |
|
|
"bind $w <KeyPress-Escape> [list tkButtonInvoke $data(cancelBtn)]\n"
|
2456 |
|
|
"bind $w <Alt-c> [list tkButtonInvoke $data(cancelBtn)]\n"
|
2457 |
|
|
"bind $w <Alt-o> [list tkButtonInvoke $data(okBtn)]\n"
|
2458 |
|
|
"wm protocol $w WM_DELETE_WINDOW [list tkColorDialog_CancelCmd $w]\n"
|
2459 |
|
|
"}\n"
|
2460 |
|
|
"proc tkColorDialog_SetRGBValue {w color} {\n"
|
2461 |
|
|
"upvar #0 $w data \n"
|
2462 |
|
|
"set data(red,intensity) [lindex $color 0]\n"
|
2463 |
|
|
"set data(green,intensity) [lindex $color 1]\n"
|
2464 |
|
|
"set data(blue,intensity) [lindex $color 2]\n"
|
2465 |
|
|
"tkColorDialog_RedrawColorBars $w all\n"
|
2466 |
|
|
"foreach color { red green blue } {\n"
|
2467 |
|
|
"set x [tkColorDialog_RgbToX $w $data($color,intensity)]\n"
|
2468 |
|
|
"tkColorDialog_MoveSelector $w $data($color,sel) $color $x 0\n"
|
2469 |
|
|
"}\n"
|
2470 |
|
|
"}\n"
|
2471 |
|
|
"proc tkColorDialog_XToRgb {w x} {\n"
|
2472 |
|
|
"upvar #0 $w data\n"
|
2473 |
|
|
"return [expr {($x * $data(intensityIncr))/ $data(colorbarWidth)}]\n"
|
2474 |
|
|
"}\n"
|
2475 |
|
|
"proc tkColorDialog_RgbToX {w color} {\n"
|
2476 |
|
|
"upvar #0 $w data\n"
|
2477 |
|
|
"return [expr {($color * $data(colorbarWidth)/ $data(intensityIncr))}]\n"
|
2478 |
|
|
"}\n"
|
2479 |
|
|
"proc tkColorDialog_DrawColorScale {w c {create 0}} {\n"
|
2480 |
|
|
"global lines\n"
|
2481 |
|
|
"upvar #0 $w data\n"
|
2482 |
|
|
"set col $data($c,col)\n"
|
2483 |
|
|
"set sel $data($c,sel)\n"
|
2484 |
|
|
"if {$create} {\n"
|
2485 |
|
|
"if { $data(lines,$c,last) > $data(lines,$c,start)} {\n"
|
2486 |
|
|
"for {set i $data(lines,$c,start)} \\\n"
|
2487 |
|
|
"\011\011{$i <= $data(lines,$c,last)} { incr i} {\n"
|
2488 |
|
|
"$sel delete $i\n"
|
2489 |
|
|
"}\n"
|
2490 |
|
|
"}\n"
|
2491 |
|
|
"if {[info exists data($c,index)]} {\n"
|
2492 |
|
|
"$sel delete $data($c,index)\n"
|
2493 |
|
|
"}\n"
|
2494 |
|
|
"tkColorDialog_CreateSelector $w $sel $c\n"
|
2495 |
|
|
"$sel bind $data($c,index) <ButtonPress-1> \\\n"
|
2496 |
|
|
"\011\011[list tkColorDialog_StartMove $w $sel $c %x $data(selPad) 1]\n"
|
2497 |
|
|
"$sel bind $data($c,index) <B1-Motion> \\\n"
|
2498 |
|
|
"\011\011[list tkColorDialog_MoveSelector $w $sel $c %x $data(selPad)]\n"
|
2499 |
|
|
"$sel bind $data($c,index) <ButtonRelease-1> \\\n"
|
2500 |
|
|
"\011\011[list tkColorDialog_ReleaseMouse $w $sel $c %x $data(selPad)]\n"
|
2501 |
|
|
"set height [winfo height $col]\n"
|
2502 |
|
|
"set data($c,clickRegion) [$sel create rectangle 0 0 \\\n"
|
2503 |
|
|
"\011\011$data(canvasWidth) $height -fill {} -outline {}]\n"
|
2504 |
|
|
"bind $col <ButtonPress-1> \\\n"
|
2505 |
|
|
"\011\011[list tkColorDialog_StartMove $w $sel $c %x $data(colorPad)]\n"
|
2506 |
|
|
"bind $col <B1-Motion> \\\n"
|
2507 |
|
|
"\011\011[list tkColorDialog_MoveSelector $w $sel $c %x $data(colorPad)]\n"
|
2508 |
|
|
"bind $col <ButtonRelease-1> \\\n"
|
2509 |
|
|
"\011\011[list tkColorDialog_ReleaseMouse $w $sel $c %x $data(colorPad)]\n"
|
2510 |
|
|
"$sel bind $data($c,clickRegion) <ButtonPress-1> \\\n"
|
2511 |
|
|
"\011\011[list tkColorDialog_StartMove $w $sel $c %x $data(selPad)]\n"
|
2512 |
|
|
"$sel bind $data($c,clickRegion) <B1-Motion> \\\n"
|
2513 |
|
|
"\011\011[list tkColorDialog_MoveSelector $w $sel $c %x $data(selPad)]\n"
|
2514 |
|
|
"$sel bind $data($c,clickRegion) <ButtonRelease-1> \\\n"
|
2515 |
|
|
"\011\011[list tkColorDialog_ReleaseMouse $w $sel $c %x $data(selPad)]\n"
|
2516 |
|
|
"} else {\n"
|
2517 |
|
|
"set l $data(lines,$c,start)\n"
|
2518 |
|
|
"}\n"
|
2519 |
|
|
"set highlightW [expr {[$col cget -highlightthickness] + [$col cget -bd]}]\n"
|
2520 |
|
|
"for {set i 0} { $i < $data(NUM_COLORBARS)} { incr i} {\n"
|
2521 |
|
|
"set intensity [expr {$i * $data(intensityIncr)}]\n"
|
2522 |
|
|
"set startx [expr {$i * $data(colorbarWidth) + $highlightW}]\n"
|
2523 |
|
|
"if {[string equal $c \"red\"]} {\n"
|
2524 |
|
|
"set color [format \"#%02x%02x%02x\" \\\n"
|
2525 |
|
|
"\011\011\011 $intensity \\\n"
|
2526 |
|
|
"\011\011\011 $data(green,intensity) \\\n"
|
2527 |
|
|
"\011\011\011 $data(blue,intensity)]\n"
|
2528 |
|
|
"} elseif {[string equal $c \"green\"]} {\n"
|
2529 |
|
|
"set color [format \"#%02x%02x%02x\" \\\n"
|
2530 |
|
|
"\011\011\011 $data(red,intensity) \\\n"
|
2531 |
|
|
"\011\011\011 $intensity \\\n"
|
2532 |
|
|
"\011\011\011 $data(blue,intensity)]\n"
|
2533 |
|
|
"} else {\n"
|
2534 |
|
|
"set color [format \"#%02x%02x%02x\" \\\n"
|
2535 |
|
|
"\011\011\011 $data(red,intensity) \\\n"
|
2536 |
|
|
"\011\011\011 $data(green,intensity) \\\n"
|
2537 |
|
|
"\011\011\011 $intensity]\n"
|
2538 |
|
|
"}\n"
|
2539 |
|
|
"if {$create} {\n"
|
2540 |
|
|
"set index [$col create rect $startx $highlightW \\\n"
|
2541 |
|
|
"\011\011 [expr {$startx +$data(colorbarWidth)}] \\\n"
|
2542 |
|
|
"\011\011 [expr {[winfo height $col] + $highlightW}]\\\n"
|
2543 |
|
|
"\011 -fill $color -outline $color]\n"
|
2544 |
|
|
"} else {\n"
|
2545 |
|
|
"$col itemconfigure $l -fill $color -outline $color\n"
|
2546 |
|
|
"incr l\n"
|
2547 |
|
|
"}\n"
|
2548 |
|
|
"}\n"
|
2549 |
|
|
"$sel raise $data($c,index)\n"
|
2550 |
|
|
"if {$create} {\n"
|
2551 |
|
|
"set data(lines,$c,last) $index\n"
|
2552 |
|
|
"set data(lines,$c,start) [expr {$index - $data(NUM_COLORBARS) + 1}]\n"
|
2553 |
|
|
"}\n"
|
2554 |
|
|
"tkColorDialog_RedrawFinalColor $w\n"
|
2555 |
|
|
"}\n"
|
2556 |
|
|
"proc tkColorDialog_CreateSelector {w sel c } {\n"
|
2557 |
|
|
"upvar #0 $w data\n"
|
2558 |
|
|
"set data($c,index) [$sel create polygon \\\n"
|
2559 |
|
|
"\0110 $data(PLGN_HEIGHT) \\\n"
|
2560 |
|
|
"\011$data(PLGN_WIDTH) $data(PLGN_HEIGHT) \\\n"
|
2561 |
|
|
"\011$data(indent) 0]\n"
|
2562 |
|
|
"set data($c,x) [tkColorDialog_RgbToX $w $data($c,intensity)]\n"
|
2563 |
|
|
"$sel move $data($c,index) $data($c,x) 0\n"
|
2564 |
|
|
"}\n"
|
2565 |
|
|
"proc tkColorDialog_RedrawFinalColor {w} {\n"
|
2566 |
|
|
"upvar #0 $w data\n"
|
2567 |
|
|
"set color [format \"#%02x%02x%02x\" $data(red,intensity) \\\n"
|
2568 |
|
|
"\011$data(green,intensity) $data(blue,intensity)]\n"
|
2569 |
|
|
"$data(finalCanvas) configure -bg $color\n"
|
2570 |
|
|
"set data(finalColor) $color\n"
|
2571 |
|
|
"set data(selection) $color\n"
|
2572 |
|
|
"set data(finalRGB) [list \\\n"
|
2573 |
|
|
"\011 $data(red,intensity) \\\n"
|
2574 |
|
|
"\011 $data(green,intensity) \\\n"
|
2575 |
|
|
"\011 $data(blue,intensity)]\n"
|
2576 |
|
|
"}\n"
|
2577 |
|
|
"proc tkColorDialog_RedrawColorBars {w colorChanged} {\n"
|
2578 |
|
|
"upvar #0 $w data\n"
|
2579 |
|
|
"switch $colorChanged {\n"
|
2580 |
|
|
"red { \n"
|
2581 |
|
|
"tkColorDialog_DrawColorScale $w green\n"
|
2582 |
|
|
"tkColorDialog_DrawColorScale $w blue\n"
|
2583 |
|
|
"}\n"
|
2584 |
|
|
"green {\n"
|
2585 |
|
|
"tkColorDialog_DrawColorScale $w red\n"
|
2586 |
|
|
"tkColorDialog_DrawColorScale $w blue\n"
|
2587 |
|
|
"}\n"
|
2588 |
|
|
"blue {\n"
|
2589 |
|
|
"tkColorDialog_DrawColorScale $w red\n"
|
2590 |
|
|
"tkColorDialog_DrawColorScale $w green\n"
|
2591 |
|
|
"}\n"
|
2592 |
|
|
"default {\n"
|
2593 |
|
|
"tkColorDialog_DrawColorScale $w red\n"
|
2594 |
|
|
"tkColorDialog_DrawColorScale $w green\n"
|
2595 |
|
|
"tkColorDialog_DrawColorScale $w blue\n"
|
2596 |
|
|
"}\n"
|
2597 |
|
|
"}\n"
|
2598 |
|
|
"tkColorDialog_RedrawFinalColor $w\n"
|
2599 |
|
|
"}\n"
|
2600 |
|
|
"proc tkColorDialog_StartMove {w sel color x delta {dontMove 0}} {\n"
|
2601 |
|
|
"upvar #0 $w data\n"
|
2602 |
|
|
"if {!$dontMove} {\n"
|
2603 |
|
|
"tkColorDialog_MoveSelector $w $sel $color $x $delta\n"
|
2604 |
|
|
"}\n"
|
2605 |
|
|
"}\n"
|
2606 |
|
|
"proc tkColorDialog_MoveSelector {w sel color x delta} {\n"
|
2607 |
|
|
"upvar #0 $w data\n"
|
2608 |
|
|
"incr x -$delta\n"
|
2609 |
|
|
"if { $x < 0 } {\n"
|
2610 |
|
|
"set x 0\n"
|
2611 |
|
|
"} elseif { $x >= $data(BARS_WIDTH)} {\n"
|
2612 |
|
|
"set x [expr {$data(BARS_WIDTH) - 1}]\n"
|
2613 |
|
|
"}\n"
|
2614 |
|
|
"set diff [expr {$x - $data($color,x)}]\n"
|
2615 |
|
|
"$sel move $data($color,index) $diff 0\n"
|
2616 |
|
|
"set data($color,x) [expr {$data($color,x) + $diff}]\n"
|
2617 |
|
|
"return $x\n"
|
2618 |
|
|
"}\n"
|
2619 |
|
|
"proc tkColorDialog_ReleaseMouse {w sel color x delta} {\n"
|
2620 |
|
|
"upvar #0 $w data \n"
|
2621 |
|
|
"set x [tkColorDialog_MoveSelector $w $sel $color $x $delta]\n"
|
2622 |
|
|
"set data($color,intensity) [tkColorDialog_XToRgb $w $x]\n"
|
2623 |
|
|
"tkColorDialog_RedrawColorBars $w $color\n"
|
2624 |
|
|
"}\n"
|
2625 |
|
|
"proc tkColorDialog_ResizeColorBars {w} {\n"
|
2626 |
|
|
"upvar #0 $w data\n"
|
2627 |
|
|
"if { ($data(BARS_WIDTH) < $data(NUM_COLORBARS)) || \n"
|
2628 |
|
|
"(($data(BARS_WIDTH) % $data(NUM_COLORBARS)) != 0)} {\n"
|
2629 |
|
|
"set data(BARS_WIDTH) $data(NUM_COLORBARS)\n"
|
2630 |
|
|
"}\n"
|
2631 |
|
|
"tkColorDialog_InitValues $w\n"
|
2632 |
|
|
"foreach color { red green blue } {\n"
|
2633 |
|
|
"$data($color,col) configure -width $data(canvasWidth)\n"
|
2634 |
|
|
"tkColorDialog_DrawColorScale $w $color 1\n"
|
2635 |
|
|
"}\n"
|
2636 |
|
|
"}\n"
|
2637 |
|
|
"proc tkColorDialog_HandleSelEntry {w} {\n"
|
2638 |
|
|
"upvar #0 $w data\n"
|
2639 |
|
|
"set text [string trim $data(selection)]\n"
|
2640 |
|
|
"if {[catch {set color [winfo rgb . $text]} ]} {\n"
|
2641 |
|
|
"set data(selection) $data(finalColor)\n"
|
2642 |
|
|
"return\n"
|
2643 |
|
|
"}\n"
|
2644 |
|
|
"set R [expr {[lindex $color 0]/0x100}]\n"
|
2645 |
|
|
"set G [expr {[lindex $color 1]/0x100}]\n"
|
2646 |
|
|
"set B [expr {[lindex $color 2]/0x100}]\n"
|
2647 |
|
|
"tkColorDialog_SetRGBValue $w \"$R $G $B\"\n"
|
2648 |
|
|
"set data(selection) $text\n"
|
2649 |
|
|
"}\n"
|
2650 |
|
|
"proc tkColorDialog_HandleRGBEntry {w} {\n"
|
2651 |
|
|
"upvar #0 $w data\n"
|
2652 |
|
|
"foreach c {red green blue} {\n"
|
2653 |
|
|
"if {[catch {\n"
|
2654 |
|
|
"set data($c,intensity) [expr {int($data($c,intensity))}]\n"
|
2655 |
|
|
"}]} {\n"
|
2656 |
|
|
"set data($c,intensity) 0\n"
|
2657 |
|
|
"}\n"
|
2658 |
|
|
"if {$data($c,intensity) < 0} {\n"
|
2659 |
|
|
"set data($c,intensity) 0\n"
|
2660 |
|
|
"}\n"
|
2661 |
|
|
"if {$data($c,intensity) > 255} {\n"
|
2662 |
|
|
"set data($c,intensity) 255\n"
|
2663 |
|
|
"}\n"
|
2664 |
|
|
"}\n"
|
2665 |
|
|
"tkColorDialog_SetRGBValue $w \"$data(red,intensity) $data(green,intensity) \\\n"
|
2666 |
|
|
"\011$data(blue,intensity)\"\n"
|
2667 |
|
|
"} \n"
|
2668 |
|
|
"proc tkColorDialog_EnterColorBar {w color} {\n"
|
2669 |
|
|
"upvar #0 $w data\n"
|
2670 |
|
|
"$data($color,sel) itemconfig $data($color,index) -fill red\n"
|
2671 |
|
|
"}\n"
|
2672 |
|
|
"proc tkColorDialog_LeaveColorBar {w color} {\n"
|
2673 |
|
|
"upvar #0 $w data\n"
|
2674 |
|
|
"$data($color,sel) itemconfig $data($color,index) -fill black\n"
|
2675 |
|
|
"}\n"
|
2676 |
|
|
"proc tkColorDialog_OkCmd {w} {\n"
|
2677 |
|
|
"global tkPriv\n"
|
2678 |
|
|
"upvar #0 $w data\n"
|
2679 |
|
|
"set tkPriv(selectColor) $data(finalColor)\n"
|
2680 |
|
|
"}\n"
|
2681 |
|
|
"proc tkColorDialog_CancelCmd {w} {\n"
|
2682 |
|
|
"global tkPriv\n"
|
2683 |
|
|
"set tkPriv(selectColor) \"\"\n"
|
2684 |
|
|
"}\n"
|
2685 |
|
|
;
|
2686 |
|
|
static char Et_zFile11[] =
|
2687 |
|
|
"proc tclParseConfigSpec {w specs flags argList} {\n"
|
2688 |
|
|
"upvar #0 $w data\n"
|
2689 |
|
|
"foreach spec $specs {\n"
|
2690 |
|
|
"if {[llength $spec] < 4} {\n"
|
2691 |
|
|
"error \"\\\"spec\\\" should contain 5 or 4 elements\"\n"
|
2692 |
|
|
"}\n"
|
2693 |
|
|
"set cmdsw [lindex $spec 0]\n"
|
2694 |
|
|
"set cmd($cmdsw) \"\"\n"
|
2695 |
|
|
"set rname($cmdsw) [lindex $spec 1]\n"
|
2696 |
|
|
"set rclass($cmdsw) [lindex $spec 2]\n"
|
2697 |
|
|
"set def($cmdsw) [lindex $spec 3]\n"
|
2698 |
|
|
"set verproc($cmdsw) [lindex $spec 4]\n"
|
2699 |
|
|
"}\n"
|
2700 |
|
|
"if {[llength $argList] & 1} {\n"
|
2701 |
|
|
"set cmdsw [lindex $argList end]\n"
|
2702 |
|
|
"if {![info exists cmd($cmdsw)]} {\n"
|
2703 |
|
|
"error \"bad option \\\"$cmdsw\\\": must be [tclListValidFlags cmd]\"\n"
|
2704 |
|
|
"}\n"
|
2705 |
|
|
"error \"value for \\\"$cmdsw\\\" missing\"\n"
|
2706 |
|
|
"}\n"
|
2707 |
|
|
"foreach cmdsw [array names cmd] {\n"
|
2708 |
|
|
"set data($cmdsw) $def($cmdsw)\n"
|
2709 |
|
|
"}\n"
|
2710 |
|
|
"foreach {cmdsw value} $argList {\n"
|
2711 |
|
|
"if {![info exists cmd($cmdsw)]} {\n"
|
2712 |
|
|
"error \"bad option \\\"$cmdsw\\\": must be [tclListValidFlags cmd]\"\n"
|
2713 |
|
|
"}\n"
|
2714 |
|
|
"set data($cmdsw) $value\n"
|
2715 |
|
|
"}\n"
|
2716 |
|
|
"}\n"
|
2717 |
|
|
"proc tclListValidFlags {v} {\n"
|
2718 |
|
|
"upvar $v cmd\n"
|
2719 |
|
|
"set len [llength [array names cmd]]\n"
|
2720 |
|
|
"set i 1\n"
|
2721 |
|
|
"set separator \"\"\n"
|
2722 |
|
|
"set errormsg \"\"\n"
|
2723 |
|
|
"foreach cmdsw [lsort [array names cmd]] {\n"
|
2724 |
|
|
"append errormsg \"$separator$cmdsw\"\n"
|
2725 |
|
|
"incr i\n"
|
2726 |
|
|
"if {$i == $len} {\n"
|
2727 |
|
|
"set separator \", or \"\n"
|
2728 |
|
|
"} else {\n"
|
2729 |
|
|
"set separator \", \"\n"
|
2730 |
|
|
"}\n"
|
2731 |
|
|
"}\n"
|
2732 |
|
|
"return $errormsg\n"
|
2733 |
|
|
"}\n"
|
2734 |
|
|
"proc tkFocusGroup_Create {t} {\n"
|
2735 |
|
|
"global tkPriv\n"
|
2736 |
|
|
"if {[string compare [winfo toplevel $t] $t]} {\n"
|
2737 |
|
|
"error \"$t is not a toplevel window\"\n"
|
2738 |
|
|
"}\n"
|
2739 |
|
|
"if {![info exists tkPriv(fg,$t)]} {\n"
|
2740 |
|
|
"set tkPriv(fg,$t) 1\n"
|
2741 |
|
|
"set tkPriv(focus,$t) \"\"\n"
|
2742 |
|
|
"bind $t <FocusIn> [list tkFocusGroup_In $t %W %d]\n"
|
2743 |
|
|
"bind $t <FocusOut> [list tkFocusGroup_Out $t %W %d]\n"
|
2744 |
|
|
"bind $t <Destroy> [list tkFocusGroup_Destroy $t %W]\n"
|
2745 |
|
|
"}\n"
|
2746 |
|
|
"}\n"
|
2747 |
|
|
"proc tkFocusGroup_BindIn {t w cmd} {\n"
|
2748 |
|
|
"global tkFocusIn tkPriv\n"
|
2749 |
|
|
"if {![info exists tkPriv(fg,$t)]} {\n"
|
2750 |
|
|
"error \"focus group \\\"$t\\\" doesn't exist\"\n"
|
2751 |
|
|
"}\n"
|
2752 |
|
|
"set tkFocusIn($t,$w) $cmd\n"
|
2753 |
|
|
"}\n"
|
2754 |
|
|
"proc tkFocusGroup_BindOut {t w cmd} {\n"
|
2755 |
|
|
"global tkFocusOut tkPriv\n"
|
2756 |
|
|
"if {![info exists tkPriv(fg,$t)]} {\n"
|
2757 |
|
|
"error \"focus group \\\"$t\\\" doesn't exist\"\n"
|
2758 |
|
|
"}\n"
|
2759 |
|
|
"set tkFocusOut($t,$w) $cmd\n"
|
2760 |
|
|
"}\n"
|
2761 |
|
|
"proc tkFocusGroup_Destroy {t w} {\n"
|
2762 |
|
|
"global tkPriv tkFocusIn tkFocusOut\n"
|
2763 |
|
|
"if {[string equal $t $w]} {\n"
|
2764 |
|
|
"unset tkPriv(fg,$t)\n"
|
2765 |
|
|
"unset tkPriv(focus,$t) \n"
|
2766 |
|
|
"foreach name [array names tkFocusIn $t,*] {\n"
|
2767 |
|
|
"unset tkFocusIn($name)\n"
|
2768 |
|
|
"}\n"
|
2769 |
|
|
"foreach name [array names tkFocusOut $t,*] {\n"
|
2770 |
|
|
"unset tkFocusOut($name)\n"
|
2771 |
|
|
"}\n"
|
2772 |
|
|
"} else {\n"
|
2773 |
|
|
"if {[info exists tkPriv(focus,$t)] && \\\n"
|
2774 |
|
|
"\011\011[string equal $tkPriv(focus,$t) $w]} {\n"
|
2775 |
|
|
"set tkPriv(focus,$t) \"\"\n"
|
2776 |
|
|
"}\n"
|
2777 |
|
|
"catch {\n"
|
2778 |
|
|
"unset tkFocusIn($t,$w)\n"
|
2779 |
|
|
"}\n"
|
2780 |
|
|
"catch {\n"
|
2781 |
|
|
"unset tkFocusOut($t,$w)\n"
|
2782 |
|
|
"}\n"
|
2783 |
|
|
"}\n"
|
2784 |
|
|
"}\n"
|
2785 |
|
|
"proc tkFocusGroup_In {t w detail} {\n"
|
2786 |
|
|
"global tkPriv tkFocusIn\n"
|
2787 |
|
|
"if {[string compare $detail NotifyNonlinear] && \\\n"
|
2788 |
|
|
"\011 [string compare $detail NotifyNonlinearVirtual]} {\n"
|
2789 |
|
|
"return\n"
|
2790 |
|
|
"}\n"
|
2791 |
|
|
"if {![info exists tkFocusIn($t,$w)]} {\n"
|
2792 |
|
|
"set tkFocusIn($t,$w) \"\"\n"
|
2793 |
|
|
"return\n"
|
2794 |
|
|
"}\n"
|
2795 |
|
|
"if {![info exists tkPriv(focus,$t)]} {\n"
|
2796 |
|
|
"return\n"
|
2797 |
|
|
"}\n"
|
2798 |
|
|
"if {[string equal $tkPriv(focus,$t) $w]} {\n"
|
2799 |
|
|
"return\n"
|
2800 |
|
|
"} else {\n"
|
2801 |
|
|
"set tkPriv(focus,$t) $w\n"
|
2802 |
|
|
"eval $tkFocusIn($t,$w)\n"
|
2803 |
|
|
"}\n"
|
2804 |
|
|
"}\n"
|
2805 |
|
|
"proc tkFocusGroup_Out {t w detail} {\n"
|
2806 |
|
|
"global tkPriv tkFocusOut\n"
|
2807 |
|
|
"if {[string compare $detail NotifyNonlinear] && \\\n"
|
2808 |
|
|
"\011 [string compare $detail NotifyNonlinearVirtual]} {\n"
|
2809 |
|
|
"return\n"
|
2810 |
|
|
"}\n"
|
2811 |
|
|
"if {![info exists tkPriv(focus,$t)]} {\n"
|
2812 |
|
|
"return\n"
|
2813 |
|
|
"}\n"
|
2814 |
|
|
"if {![info exists tkFocusOut($t,$w)]} {\n"
|
2815 |
|
|
"return\n"
|
2816 |
|
|
"} else {\n"
|
2817 |
|
|
"eval $tkFocusOut($t,$w)\n"
|
2818 |
|
|
"set tkPriv(focus,$t) \"\"\n"
|
2819 |
|
|
"}\n"
|
2820 |
|
|
"}\n"
|
2821 |
|
|
"proc tkFDGetFileTypes {string} {\n"
|
2822 |
|
|
"foreach t $string {\n"
|
2823 |
|
|
"if {[llength $t] < 2 || [llength $t] > 3} {\n"
|
2824 |
|
|
"error \"bad file type \\\"$t\\\", should be \\\"typeName {extension ?extensions ...?} ?{macType ?macTypes ...?}?\\\"\"\n"
|
2825 |
|
|
"}\n"
|
2826 |
|
|
"eval lappend [list fileTypes([lindex $t 0])] [lindex $t 1]\n"
|
2827 |
|
|
"}\n"
|
2828 |
|
|
"set types {}\n"
|
2829 |
|
|
"foreach t $string {\n"
|
2830 |
|
|
"set label [lindex $t 0]\n"
|
2831 |
|
|
"set exts {}\n"
|
2832 |
|
|
"if {[info exists hasDoneType($label)]} {\n"
|
2833 |
|
|
"continue\n"
|
2834 |
|
|
"}\n"
|
2835 |
|
|
"set name \"$label (\"\n"
|
2836 |
|
|
"set sep \"\"\n"
|
2837 |
|
|
"foreach ext $fileTypes($label) {\n"
|
2838 |
|
|
"if {[string equal $ext \"\"]} {\n"
|
2839 |
|
|
"continue\n"
|
2840 |
|
|
"}\n"
|
2841 |
|
|
"regsub {^[.]} $ext \"*.\" ext\n"
|
2842 |
|
|
"if {![info exists hasGotExt($label,$ext)]} {\n"
|
2843 |
|
|
"append name $sep$ext\n"
|
2844 |
|
|
"lappend exts $ext\n"
|
2845 |
|
|
"set hasGotExt($label,$ext) 1\n"
|
2846 |
|
|
"}\n"
|
2847 |
|
|
"set sep ,\n"
|
2848 |
|
|
"}\n"
|
2849 |
|
|
"append name \")\"\n"
|
2850 |
|
|
"lappend types [list $name $exts]\n"
|
2851 |
|
|
"set hasDoneType($label) 1\n"
|
2852 |
|
|
"}\n"
|
2853 |
|
|
"return $types\n"
|
2854 |
|
|
"}\n"
|
2855 |
|
|
;
|
2856 |
|
|
static char Et_zFile12[] =
|
2857 |
|
|
"proc tkConsoleInit {} {\n"
|
2858 |
|
|
"global tcl_platform\n"
|
2859 |
|
|
"if {![consoleinterp eval {set tcl_interactive}]} {\n"
|
2860 |
|
|
"wm withdraw .\n"
|
2861 |
|
|
"}\n"
|
2862 |
|
|
"if {[string compare $tcl_platform(platform) \"macintosh\"]} {\n"
|
2863 |
|
|
"set mod \"Ctrl\"\n"
|
2864 |
|
|
"} else {\n"
|
2865 |
|
|
"set mod \"Cmd\"\n"
|
2866 |
|
|
"}\n"
|
2867 |
|
|
"menu .menubar\n"
|
2868 |
|
|
".menubar add cascade -label File -menu .menubar.file -underline 0\n"
|
2869 |
|
|
".menubar add cascade -label Edit -menu .menubar.edit -underline 0\n"
|
2870 |
|
|
"menu .menubar.file -tearoff 0\n"
|
2871 |
|
|
".menubar.file add command -label \"Source...\" -underline 0 \\\n"
|
2872 |
|
|
"\011 -command tkConsoleSource\n"
|
2873 |
|
|
".menubar.file add command -label \"Hide Console\" -underline 0 \\\n"
|
2874 |
|
|
"\011 -command {wm withdraw .}\n"
|
2875 |
|
|
"if {[string compare $tcl_platform(platform) \"macintosh\"]} {\n"
|
2876 |
|
|
".menubar.file add command -label \"Exit\" -underline 1 -command exit\n"
|
2877 |
|
|
"} else {\n"
|
2878 |
|
|
".menubar.file add command -label \"Quit\" -command exit -accel Cmd-Q\n"
|
2879 |
|
|
"}\n"
|
2880 |
|
|
"menu .menubar.edit -tearoff 0\n"
|
2881 |
|
|
".menubar.edit add command -label \"Cut\" -underline 2 \\\n"
|
2882 |
|
|
"\011 -command { event generate .console <<Cut>> } -accel \"$mod+X\"\n"
|
2883 |
|
|
".menubar.edit add command -label \"Copy\" -underline 0 \\\n"
|
2884 |
|
|
"\011 -command { event generate .console <<Copy>> } -accel \"$mod+C\"\n"
|
2885 |
|
|
".menubar.edit add command -label \"Paste\" -underline 1 \\\n"
|
2886 |
|
|
"\011 -command { event generate .console <<Paste>> } -accel \"$mod+V\"\n"
|
2887 |
|
|
"if {[string compare $tcl_platform(platform) \"windows\"]} {\n"
|
2888 |
|
|
".menubar.edit add command -label \"Clear\" -underline 2 \\\n"
|
2889 |
|
|
"\011\011-command { event generate .console <<Clear>> }\n"
|
2890 |
|
|
"} else {\n"
|
2891 |
|
|
".menubar.edit add command -label \"Delete\" -underline 0 \\\n"
|
2892 |
|
|
"\011\011-command { event generate .console <<Clear>> } -accel \"Del\"\n"
|
2893 |
|
|
".menubar add cascade -label Help -menu .menubar.help -underline 0\n"
|
2894 |
|
|
"menu .menubar.help -tearoff 0\n"
|
2895 |
|
|
".menubar.help add command -label \"About...\" -underline 0 \\\n"
|
2896 |
|
|
"\011\011-command tkConsoleAbout\n"
|
2897 |
|
|
"}\n"
|
2898 |
|
|
". configure -menu .menubar\n"
|
2899 |
|
|
"text .console -yscrollcommand \".sb set\" -setgrid true \n"
|
2900 |
|
|
"scrollbar .sb -command \".console yview\"\n"
|
2901 |
|
|
"pack .sb -side right -fill both\n"
|
2902 |
|
|
"pack .console -fill both -expand 1 -side left\n"
|
2903 |
|
|
"switch -exact $tcl_platform(platform) {\n"
|
2904 |
|
|
"\"macintosh\" {\n"
|
2905 |
|
|
".console configure -font {Monaco 9 normal} -highlightthickness 0\n"
|
2906 |
|
|
"}\n"
|
2907 |
|
|
"\"windows\" {\n"
|
2908 |
|
|
".console configure -font systemfixed\n"
|
2909 |
|
|
"}\n"
|
2910 |
|
|
"}\n"
|
2911 |
|
|
"tkConsoleBind .console\n"
|
2912 |
|
|
".console tag configure stderr -foreground red\n"
|
2913 |
|
|
".console tag configure stdin -foreground blue\n"
|
2914 |
|
|
"focus .console\n"
|
2915 |
|
|
"wm protocol . WM_DELETE_WINDOW { wm withdraw . }\n"
|
2916 |
|
|
"wm title . \"" BUILD_CONFIG_STATIC_WISH_ALIAS " v" BUILD_CONFIG_RELEASE_VERSION "\"\n"
|
2917 |
|
|
"flush stdout\n"
|
2918 |
|
|
".console mark set output [.console index \"end - 1 char\"]\n"
|
2919 |
|
|
"tkTextSetCursor .console end\n"
|
2920 |
|
|
".console mark set promptEnd insert\n"
|
2921 |
|
|
".console mark gravity promptEnd left\n"
|
2922 |
|
|
"}\n"
|
2923 |
|
|
"proc tkConsoleSource {} {\n"
|
2924 |
|
|
"set filename [tk_getOpenFile -defaultextension .tcl -parent . \\\n"
|
2925 |
|
|
"\011\011 -title \"Select a file to source\" \\\n"
|
2926 |
|
|
"\011\011 -filetypes {{\"Tcl Scripts\" .tcl} {\"All Files\" *}}]\n"
|
2927 |
|
|
"if {[string compare $filename \"\"]} {\n"
|
2928 |
|
|
"set cmd [list source $filename]\n"
|
2929 |
|
|
"if {[catch {consoleinterp eval $cmd} result]} {\n"
|
2930 |
|
|
"tkConsoleOutput stderr \"$result\\n\"\n"
|
2931 |
|
|
"}\n"
|
2932 |
|
|
"}\n"
|
2933 |
|
|
"}\n"
|
2934 |
|
|
"proc tkConsoleInvoke {args} {\n"
|
2935 |
|
|
"set ranges [.console tag ranges input]\n"
|
2936 |
|
|
"set cmd \"\"\n"
|
2937 |
|
|
"if {[llength $ranges]} {\n"
|
2938 |
|
|
"set pos 0\n"
|
2939 |
|
|
"while {[string compare [lindex $ranges $pos] \"\"]} {\n"
|
2940 |
|
|
"set start [lindex $ranges $pos]\n"
|
2941 |
|
|
"set end [lindex $ranges [incr pos]]\n"
|
2942 |
|
|
"append cmd [.console get $start $end]\n"
|
2943 |
|
|
"incr pos\n"
|
2944 |
|
|
"}\n"
|
2945 |
|
|
"}\n"
|
2946 |
|
|
"if {[string equal $cmd \"\"]} {\n"
|
2947 |
|
|
"tkConsolePrompt\n"
|
2948 |
|
|
"} elseif {[info complete $cmd]} {\n"
|
2949 |
|
|
".console mark set output end\n"
|
2950 |
|
|
".console tag delete input\n"
|
2951 |
|
|
"set result [consoleinterp record $cmd]\n"
|
2952 |
|
|
"if {[string compare $result \"\"]} {\n"
|
2953 |
|
|
"puts $result\n"
|
2954 |
|
|
"}\n"
|
2955 |
|
|
"tkConsoleHistory reset\n"
|
2956 |
|
|
"tkConsolePrompt\n"
|
2957 |
|
|
"} else {\n"
|
2958 |
|
|
"tkConsolePrompt partial\n"
|
2959 |
|
|
"}\n"
|
2960 |
|
|
".console yview -pickplace insert\n"
|
2961 |
|
|
"}\n"
|
2962 |
|
|
"set histNum 1\n"
|
2963 |
|
|
"proc tkConsoleHistory {cmd} {\n"
|
2964 |
|
|
"global histNum\n"
|
2965 |
|
|
"switch $cmd {\n"
|
2966 |
|
|
"prev {\n"
|
2967 |
|
|
"incr histNum -1\n"
|
2968 |
|
|
"if {$histNum == 0} {\n"
|
2969 |
|
|
"set cmd {history event [expr {[history nextid] -1}]}\n"
|
2970 |
|
|
"} else {\n"
|
2971 |
|
|
"set cmd \"history event $histNum\"\n"
|
2972 |
|
|
"}\n"
|
2973 |
|
|
"if {[catch {consoleinterp eval $cmd} cmd]} {\n"
|
2974 |
|
|
"incr histNum\n"
|
2975 |
|
|
"return\n"
|
2976 |
|
|
"}\n"
|
2977 |
|
|
".console delete promptEnd end\n"
|
2978 |
|
|
".console insert promptEnd $cmd {input stdin}\n"
|
2979 |
|
|
"}\n"
|
2980 |
|
|
"next {\n"
|
2981 |
|
|
"incr histNum\n"
|
2982 |
|
|
"if {$histNum == 0} {\n"
|
2983 |
|
|
"set cmd {history event [expr {[history nextid] -1}]}\n"
|
2984 |
|
|
"} elseif {$histNum > 0} {\n"
|
2985 |
|
|
"set cmd \"\"\n"
|
2986 |
|
|
"set histNum 1\n"
|
2987 |
|
|
"} else {\n"
|
2988 |
|
|
"set cmd \"history event $histNum\"\n"
|
2989 |
|
|
"}\n"
|
2990 |
|
|
"if {[string compare $cmd \"\"]} {\n"
|
2991 |
|
|
"catch {consoleinterp eval $cmd} cmd\n"
|
2992 |
|
|
"}\n"
|
2993 |
|
|
".console delete promptEnd end\n"
|
2994 |
|
|
".console insert promptEnd $cmd {input stdin}\n"
|
2995 |
|
|
"}\n"
|
2996 |
|
|
"reset {\n"
|
2997 |
|
|
"set histNum 1\n"
|
2998 |
|
|
"}\n"
|
2999 |
|
|
"}\n"
|
3000 |
|
|
"}\n"
|
3001 |
|
|
"proc tkConsolePrompt {{partial normal}} {\n"
|
3002 |
|
|
"if {[string equal $partial \"normal\"]} {\n"
|
3003 |
|
|
"set temp [.console index \"end - 1 char\"]\n"
|
3004 |
|
|
".console mark set output end\n"
|
3005 |
|
|
"if {[consoleinterp eval \"info exists tcl_prompt1\"]} {\n"
|
3006 |
|
|
"consoleinterp eval \"eval \\[set tcl_prompt1\\]\"\n"
|
3007 |
|
|
"} else {\n"
|
3008 |
|
|
"puts -nonewline \"% \"\n"
|
3009 |
|
|
"}\n"
|
3010 |
|
|
"} else {\n"
|
3011 |
|
|
"set temp [.console index output]\n"
|
3012 |
|
|
".console mark set output end\n"
|
3013 |
|
|
"if {[consoleinterp eval \"info exists tcl_prompt2\"]} {\n"
|
3014 |
|
|
"consoleinterp eval \"eval \\[set tcl_prompt2\\]\"\n"
|
3015 |
|
|
"} else {\n"
|
3016 |
|
|
"puts -nonewline \"> \"\n"
|
3017 |
|
|
"}\n"
|
3018 |
|
|
"}\n"
|
3019 |
|
|
"flush stdout\n"
|
3020 |
|
|
".console mark set output $temp\n"
|
3021 |
|
|
"tkTextSetCursor .console end\n"
|
3022 |
|
|
".console mark set promptEnd insert\n"
|
3023 |
|
|
".console mark gravity promptEnd left\n"
|
3024 |
|
|
"}\n"
|
3025 |
|
|
"proc tkConsoleBind {win} {\n"
|
3026 |
|
|
"bindtags $win \"$win Text . all\"\n"
|
3027 |
|
|
"bind $win <Alt-KeyPress> {# nothing }\n"
|
3028 |
|
|
"bind $win <Meta-KeyPress> {# nothing}\n"
|
3029 |
|
|
"bind $win <Control-KeyPress> {# nothing}\n"
|
3030 |
|
|
"bind $win <Escape> {# nothing}\n"
|
3031 |
|
|
"bind $win <KP_Enter> {# nothing}\n"
|
3032 |
|
|
"bind $win <Tab> {\n"
|
3033 |
|
|
"tkConsoleInsert %W \\t\n"
|
3034 |
|
|
"focus %W\n"
|
3035 |
|
|
"break\n"
|
3036 |
|
|
"}\n"
|
3037 |
|
|
"bind $win <Return> {\n"
|
3038 |
|
|
"%W mark set insert {end - 1c}\n"
|
3039 |
|
|
"tkConsoleInsert %W \"\\n\"\n"
|
3040 |
|
|
"tkConsoleInvoke\n"
|
3041 |
|
|
"break\n"
|
3042 |
|
|
"}\n"
|
3043 |
|
|
"bind $win <Delete> {\n"
|
3044 |
|
|
"if {[string compare [%W tag nextrange sel 1.0 end] \"\"]} {\n"
|
3045 |
|
|
"%W tag remove sel sel.first promptEnd\n"
|
3046 |
|
|
"} elseif {[%W compare insert < promptEnd]} {\n"
|
3047 |
|
|
"break\n"
|
3048 |
|
|
"}\n"
|
3049 |
|
|
"}\n"
|
3050 |
|
|
"bind $win <BackSpace> {\n"
|
3051 |
|
|
"if {[string compare [%W tag nextrange sel 1.0 end] \"\"]} {\n"
|
3052 |
|
|
"%W tag remove sel sel.first promptEnd\n"
|
3053 |
|
|
"} elseif {[%W compare insert <= promptEnd]} {\n"
|
3054 |
|
|
"break\n"
|
3055 |
|
|
"}\n"
|
3056 |
|
|
"}\n"
|
3057 |
|
|
"foreach left {Control-a Home} {\n"
|
3058 |
|
|
"bind $win <$left> {\n"
|
3059 |
|
|
"if {[%W compare insert < promptEnd]} {\n"
|
3060 |
|
|
"tkTextSetCursor %W {insert linestart}\n"
|
3061 |
|
|
"} else {\n"
|
3062 |
|
|
"tkTextSetCursor %W promptEnd\n"
|
3063 |
|
|
"}\n"
|
3064 |
|
|
"break\n"
|
3065 |
|
|
"}\n"
|
3066 |
|
|
"}\n"
|
3067 |
|
|
"foreach right {Control-e End} {\n"
|
3068 |
|
|
"bind $win <$right> {\n"
|
3069 |
|
|
"tkTextSetCursor %W {insert lineend}\n"
|
3070 |
|
|
"break\n"
|
3071 |
|
|
"}\n"
|
3072 |
|
|
"}\n"
|
3073 |
|
|
"bind $win <Control-d> {\n"
|
3074 |
|
|
"if {[%W compare insert < promptEnd]} {\n"
|
3075 |
|
|
"break\n"
|
3076 |
|
|
"}\n"
|
3077 |
|
|
"}\n"
|
3078 |
|
|
"bind $win <Control-k> {\n"
|
3079 |
|
|
"if {[%W compare insert < promptEnd]} {\n"
|
3080 |
|
|
"%W mark set insert promptEnd\n"
|
3081 |
|
|
"}\n"
|
3082 |
|
|
"}\n"
|
3083 |
|
|
"bind $win <Control-t> {\n"
|
3084 |
|
|
"if {[%W compare insert < promptEnd]} {\n"
|
3085 |
|
|
"break\n"
|
3086 |
|
|
"}\n"
|
3087 |
|
|
"}\n"
|
3088 |
|
|
"bind $win <Meta-d> {\n"
|
3089 |
|
|
"if {[%W compare insert < promptEnd]} {\n"
|
3090 |
|
|
"break\n"
|
3091 |
|
|
"}\n"
|
3092 |
|
|
"}\n"
|
3093 |
|
|
"bind $win <Meta-BackSpace> {\n"
|
3094 |
|
|
"if {[%W compare insert <= promptEnd]} {\n"
|
3095 |
|
|
"break\n"
|
3096 |
|
|
"}\n"
|
3097 |
|
|
"}\n"
|
3098 |
|
|
"bind $win <Control-h> {\n"
|
3099 |
|
|
"if {[%W compare insert <= promptEnd]} {\n"
|
3100 |
|
|
"break\n"
|
3101 |
|
|
"}\n"
|
3102 |
|
|
"}\n"
|
3103 |
|
|
"foreach prev {Control-p Up} {\n"
|
3104 |
|
|
"bind $win <$prev> {\n"
|
3105 |
|
|
"tkConsoleHistory prev\n"
|
3106 |
|
|
"break\n"
|
3107 |
|
|
"}\n"
|
3108 |
|
|
"}\n"
|
3109 |
|
|
"foreach prev {Control-n Down} {\n"
|
3110 |
|
|
"bind $win <$prev> {\n"
|
3111 |
|
|
"tkConsoleHistory next\n"
|
3112 |
|
|
"break\n"
|
3113 |
|
|
"}\n"
|
3114 |
|
|
"}\n"
|
3115 |
|
|
"bind $win <Insert> {\n"
|
3116 |
|
|
"catch {tkConsoleInsert %W [selection get -displayof %W]}\n"
|
3117 |
|
|
"break\n"
|
3118 |
|
|
"}\n"
|
3119 |
|
|
"bind $win <KeyPress> {\n"
|
3120 |
|
|
"tkConsoleInsert %W %A\n"
|
3121 |
|
|
"break\n"
|
3122 |
|
|
"}\n"
|
3123 |
|
|
"foreach left {Control-b Left} {\n"
|
3124 |
|
|
"bind $win <$left> {\n"
|
3125 |
|
|
"if {[%W compare insert == promptEnd]} {\n"
|
3126 |
|
|
"break\n"
|
3127 |
|
|
"}\n"
|
3128 |
|
|
"tkTextSetCursor %W insert-1c\n"
|
3129 |
|
|
"break\n"
|
3130 |
|
|
"}\n"
|
3131 |
|
|
"}\n"
|
3132 |
|
|
"foreach right {Control-f Right} {\n"
|
3133 |
|
|
"bind $win <$right> {\n"
|
3134 |
|
|
"tkTextSetCursor %W insert+1c\n"
|
3135 |
|
|
"break\n"
|
3136 |
|
|
"}\n"
|
3137 |
|
|
"}\n"
|
3138 |
|
|
"bind $win <F9> {\n"
|
3139 |
|
|
"eval destroy [winfo child .]\n"
|
3140 |
|
|
"if {[string equal $tcl_platform(platform) \"macintosh\"]} {\n"
|
3141 |
|
|
"source -rsrc Console\n"
|
3142 |
|
|
"} else {\n"
|
3143 |
|
|
"source [file join $tk_library console.tcl]\n"
|
3144 |
|
|
"}\n"
|
3145 |
|
|
"}\n"
|
3146 |
|
|
"bind $win <<Cut>> {\n"
|
3147 |
|
|
"if {![catch {set data [%W get sel.first sel.last]}]} {\n"
|
3148 |
|
|
"clipboard clear -displayof %W\n"
|
3149 |
|
|
"clipboard append -displayof %W $data\n"
|
3150 |
|
|
"}\n"
|
3151 |
|
|
"break\n"
|
3152 |
|
|
"}\n"
|
3153 |
|
|
"bind $win <<Copy>> {\n"
|
3154 |
|
|
"if {![catch {set data [%W get sel.first sel.last]}]} {\n"
|
3155 |
|
|
"clipboard clear -displayof %W\n"
|
3156 |
|
|
"clipboard append -displayof %W $data\n"
|
3157 |
|
|
"}\n"
|
3158 |
|
|
"break\n"
|
3159 |
|
|
"}\n"
|
3160 |
|
|
"bind $win <<Paste>> {\n"
|
3161 |
|
|
"catch {\n"
|
3162 |
|
|
"set clip [selection get -displayof %W -selection CLIPBOARD]\n"
|
3163 |
|
|
"set list [split $clip \\n\\r]\n"
|
3164 |
|
|
"tkConsoleInsert %W [lindex $list 0]\n"
|
3165 |
|
|
"foreach x [lrange $list 1 end] {\n"
|
3166 |
|
|
"%W mark set insert {end - 1c}\n"
|
3167 |
|
|
"tkConsoleInsert %W \"\\n\"\n"
|
3168 |
|
|
"tkConsoleInvoke\n"
|
3169 |
|
|
"tkConsoleInsert %W $x\n"
|
3170 |
|
|
"}\n"
|
3171 |
|
|
"}\n"
|
3172 |
|
|
"break\n"
|
3173 |
|
|
"}\n"
|
3174 |
|
|
"}\n"
|
3175 |
|
|
"proc tkConsoleInsert {w s} {\n"
|
3176 |
|
|
"if {[string equal $s \"\"]} {\n"
|
3177 |
|
|
"return\n"
|
3178 |
|
|
"}\n"
|
3179 |
|
|
"catch {\n"
|
3180 |
|
|
"if {[$w compare sel.first <= insert]\n"
|
3181 |
|
|
"&& [$w compare sel.last >= insert]} {\n"
|
3182 |
|
|
"$w tag remove sel sel.first promptEnd\n"
|
3183 |
|
|
"$w delete sel.first sel.last\n"
|
3184 |
|
|
"}\n"
|
3185 |
|
|
"}\n"
|
3186 |
|
|
"if {[$w compare insert < promptEnd]} {\n"
|
3187 |
|
|
"$w mark set insert end\011\n"
|
3188 |
|
|
"}\n"
|
3189 |
|
|
"$w insert insert $s {input stdin}\n"
|
3190 |
|
|
"$w see insert\n"
|
3191 |
|
|
"}\n"
|
3192 |
|
|
"proc tkConsoleOutput {dest string} {\n"
|
3193 |
|
|
".console insert output $string $dest\n"
|
3194 |
|
|
".console see insert\n"
|
3195 |
|
|
"}\n"
|
3196 |
|
|
"proc tkConsoleExit {} {\n"
|
3197 |
|
|
"destroy .\n"
|
3198 |
|
|
"}\n"
|
3199 |
|
|
"proc tkConsoleAbout {} {\n"
|
3200 |
|
|
"global tk_patchLevel\n"
|
3201 |
|
|
"tk_messageBox -type ok -message \""
|
3202 |
|
|
BUILD_CONFIG_STATIC_WISH_ALIAS
|
3203 |
|
|
" for Windows, Version "
|
3204 |
|
|
BUILD_CONFIG_RELEASE_VERSION ", " BUILD_CONFIG_RELEASE_YEAR ".\n"
|
3205 |
|
|
"This product is an open-source static port of\n"
|
3206 |
|
|
"Tcl/Tk 8.3.1, originally from Scriptics. This product\n"
|
3207 |
|
|
"and its source code can be downloaded at no charge\n"
|
3208 |
|
|
"from http://ijutools.sourceforge.net, and is licensed\n"
|
3209 |
|
|
"under the GNU Public License (GPL).\n"
|
3210 |
|
|
"(Core components: Tcl [info patchlevel], Tk $tk_patchLevel.)\"\n"
|
3211 |
|
|
"}\n"
|
3212 |
|
|
"tkConsoleInit\n"
|
3213 |
|
|
;
|
3214 |
|
|
static char Et_zFile13[] =
|
3215 |
|
|
"proc tk_dialog {w title text bitmap default args} {\n"
|
3216 |
|
|
"global tkPriv tcl_platform\n"
|
3217 |
|
|
"if {[string is int $default]} {\n"
|
3218 |
|
|
"if {$default >= [llength $args]} {\n"
|
3219 |
|
|
"return -code error \"default button index greater than number of\\\n"
|
3220 |
|
|
"\011\011 buttons specified for tk_dialog\"\n"
|
3221 |
|
|
"}\n"
|
3222 |
|
|
"} elseif {[string equal {} $default]} {\n"
|
3223 |
|
|
"set default -1\n"
|
3224 |
|
|
"} else {\n"
|
3225 |
|
|
"set default [lsearch -exact $args $default]\n"
|
3226 |
|
|
"}\n"
|
3227 |
|
|
"catch {destroy $w}\n"
|
3228 |
|
|
"toplevel $w -class Dialog\n"
|
3229 |
|
|
"wm title $w $title\n"
|
3230 |
|
|
"wm iconname $w Dialog\n"
|
3231 |
|
|
"wm protocol $w WM_DELETE_WINDOW { }\n"
|
3232 |
|
|
"if { [winfo viewable [winfo toplevel [winfo parent $w]]] } {\n"
|
3233 |
|
|
"wm transient $w [winfo toplevel [winfo parent $w]]\n"
|
3234 |
|
|
"} \n"
|
3235 |
|
|
"if {[string equal $tcl_platform(platform) \"macintosh\"]} {\n"
|
3236 |
|
|
"unsupported1 style $w dBoxProc\n"
|
3237 |
|
|
"}\n"
|
3238 |
|
|
"frame $w.bot\n"
|
3239 |
|
|
"frame $w.top\n"
|
3240 |
|
|
"if {[string equal $tcl_platform(platform) \"unix\"]} {\n"
|
3241 |
|
|
"$w.bot configure -relief raised -bd 1\n"
|
3242 |
|
|
"$w.top configure -relief raised -bd 1\n"
|
3243 |
|
|
"}\n"
|
3244 |
|
|
"pack $w.bot -side bottom -fill both\n"
|
3245 |
|
|
"pack $w.top -side top -fill both -expand 1\n"
|
3246 |
|
|
"option add *Dialog.msg.wrapLength 3i widgetDefault\n"
|
3247 |
|
|
"if {[string equal $tcl_platform(platform) \"macintosh\"]} {\n"
|
3248 |
|
|
"option add *Dialog.msg.font system widgetDefault\n"
|
3249 |
|
|
"} else {\n"
|
3250 |
|
|
"option add *Dialog.msg.font {Times 12} widgetDefault\n"
|
3251 |
|
|
"}\n"
|
3252 |
|
|
"label $w.msg -justify left -text $text\n"
|
3253 |
|
|
"pack $w.msg -in $w.top -side right -expand 1 -fill both -padx 3m -pady 3m\n"
|
3254 |
|
|
"if {[string compare $bitmap \"\"]} {\n"
|
3255 |
|
|
"if {[string equal $tcl_platform(platform) \"macintosh\"] && \\\n"
|
3256 |
|
|
"\011\011[string equal $bitmap \"error\"]} {\n"
|
3257 |
|
|
"set bitmap \"stop\"\n"
|
3258 |
|
|
"}\n"
|
3259 |
|
|
"label $w.bitmap -bitmap $bitmap\n"
|
3260 |
|
|
"pack $w.bitmap -in $w.top -side left -padx 3m -pady 3m\n"
|
3261 |
|
|
"}\n"
|
3262 |
|
|
"set i 0\n"
|
3263 |
|
|
"foreach but $args {\n"
|
3264 |
|
|
"button $w.button$i -text $but -command [list set tkPriv(button) $i]\n"
|
3265 |
|
|
"if {$i == $default} {\n"
|
3266 |
|
|
"$w.button$i configure -default active\n"
|
3267 |
|
|
"} else {\n"
|
3268 |
|
|
"$w.button$i configure -default normal\n"
|
3269 |
|
|
"}\n"
|
3270 |
|
|
"grid $w.button$i -in $w.bot -column $i -row 0 -sticky ew -padx 10\n"
|
3271 |
|
|
"grid columnconfigure $w.bot $i\n"
|
3272 |
|
|
"if {[string equal $tcl_platform(platform) \"macintosh\"]} {\n"
|
3273 |
|
|
"set tmp [string tolower $but]\n"
|
3274 |
|
|
"if {[string equal $tmp \"ok\"] || [string equal $tmp \"cancel\"]} {\n"
|
3275 |
|
|
"grid columnconfigure $w.bot $i -minsize [expr {59 + 20}]\n"
|
3276 |
|
|
"}\n"
|
3277 |
|
|
"}\n"
|
3278 |
|
|
"incr i\n"
|
3279 |
|
|
"}\n"
|
3280 |
|
|
"if {$default >= 0} {\n"
|
3281 |
|
|
"bind $w <Return> \"\n"
|
3282 |
|
|
"[list $w.button$default] configure -state active -relief sunken\n"
|
3283 |
|
|
"update idletasks\n"
|
3284 |
|
|
"after 100\n"
|
3285 |
|
|
"set tkPriv(button) $default\n"
|
3286 |
|
|
"\"\n"
|
3287 |
|
|
"}\n"
|
3288 |
|
|
"bind $w <Destroy> {set tkPriv(button) -1}\n"
|
3289 |
|
|
"wm withdraw $w\n"
|
3290 |
|
|
"update idletasks\n"
|
3291 |
|
|
"set x [expr {[winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \\\n"
|
3292 |
|
|
"\011 - [winfo vrootx [winfo parent $w]]}]\n"
|
3293 |
|
|
"set y [expr {[winfo screenheight $w]/2 - [winfo reqheight $w]/2 \\\n"
|
3294 |
|
|
"\011 - [winfo vrooty [winfo parent $w]]}]\n"
|
3295 |
|
|
"wm geom $w +$x+$y\n"
|
3296 |
|
|
"wm deiconify $w\n"
|
3297 |
|
|
"set oldFocus [focus]\n"
|
3298 |
|
|
"set oldGrab [grab current $w]\n"
|
3299 |
|
|
"if {[string compare $oldGrab \"\"]} {\n"
|
3300 |
|
|
"set grabStatus [grab status $oldGrab]\n"
|
3301 |
|
|
"}\n"
|
3302 |
|
|
"grab $w\n"
|
3303 |
|
|
"if {$default >= 0} {\n"
|
3304 |
|
|
"focus $w.button$default\n"
|
3305 |
|
|
"} else {\n"
|
3306 |
|
|
"focus $w\n"
|
3307 |
|
|
"}\n"
|
3308 |
|
|
"tkwait variable tkPriv(button)\n"
|
3309 |
|
|
"catch {focus $oldFocus}\n"
|
3310 |
|
|
"catch {\n"
|
3311 |
|
|
"bind $w <Destroy> {}\n"
|
3312 |
|
|
"destroy $w\n"
|
3313 |
|
|
"}\n"
|
3314 |
|
|
"if {[string compare $oldGrab \"\"]} {\n"
|
3315 |
|
|
"if {[string compare $grabStatus \"global\"]} {\n"
|
3316 |
|
|
"grab $oldGrab\n"
|
3317 |
|
|
"} else {\n"
|
3318 |
|
|
"grab -global $oldGrab\n"
|
3319 |
|
|
"}\n"
|
3320 |
|
|
"}\n"
|
3321 |
|
|
"return $tkPriv(button)\n"
|
3322 |
|
|
"}\n"
|
3323 |
|
|
;
|
3324 |
|
|
static char Et_zFile14[] =
|
3325 |
|
|
"bind Entry <<Cut>> {\n"
|
3326 |
|
|
"if {![catch {tkEntryGetSelection %W} tkPriv(data)]} {\n"
|
3327 |
|
|
"clipboard clear -displayof %W\n"
|
3328 |
|
|
"clipboard append -displayof %W $tkPriv(data)\n"
|
3329 |
|
|
"%W delete sel.first sel.last\n"
|
3330 |
|
|
"unset tkPriv(data)\n"
|
3331 |
|
|
"}\n"
|
3332 |
|
|
"}\n"
|
3333 |
|
|
"bind Entry <<Copy>> {\n"
|
3334 |
|
|
"if {![catch {tkEntryGetSelection %W} tkPriv(data)]} {\n"
|
3335 |
|
|
"clipboard clear -displayof %W\n"
|
3336 |
|
|
"clipboard append -displayof %W $tkPriv(data)\n"
|
3337 |
|
|
"unset tkPriv(data)\n"
|
3338 |
|
|
"}\n"
|
3339 |
|
|
"}\n"
|
3340 |
|
|
"bind Entry <<Paste>> {\n"
|
3341 |
|
|
"global tcl_platform\n"
|
3342 |
|
|
"catch {\n"
|
3343 |
|
|
"if {[string compare $tcl_platform(platform) \"unix\"]} {\n"
|
3344 |
|
|
"catch {\n"
|
3345 |
|
|
"%W delete sel.first sel.last\n"
|
3346 |
|
|
"}\n"
|
3347 |
|
|
"}\n"
|
3348 |
|
|
"%W insert insert [selection get -displayof %W -selection CLIPBOARD]\n"
|
3349 |
|
|
"tkEntrySeeInsert %W\n"
|
3350 |
|
|
"}\n"
|
3351 |
|
|
"}\n"
|
3352 |
|
|
"bind Entry <<Clear>> {\n"
|
3353 |
|
|
"%W delete sel.first sel.last\n"
|
3354 |
|
|
"}\n"
|
3355 |
|
|
"bind Entry <<PasteSelection>> {\n"
|
3356 |
|
|
"if {!$tkPriv(mouseMoved) || $tk_strictMotif} {\n"
|
3357 |
|
|
"tkEntryPaste %W %x\n"
|
3358 |
|
|
"}\n"
|
3359 |
|
|
"}\n"
|
3360 |
|
|
"bind Entry <1> {\n"
|
3361 |
|
|
"tkEntryButton1 %W %x\n"
|
3362 |
|
|
"%W selection clear\n"
|
3363 |
|
|
"}\n"
|
3364 |
|
|
"bind Entry <B1-Motion> {\n"
|
3365 |
|
|
"set tkPriv(x) %x\n"
|
3366 |
|
|
"tkEntryMouseSelect %W %x\n"
|
3367 |
|
|
"}\n"
|
3368 |
|
|
"bind Entry <Double-1> {\n"
|
3369 |
|
|
"set tkPriv(selectMode) word\n"
|
3370 |
|
|
"tkEntryMouseSelect %W %x\n"
|
3371 |
|
|
"catch {%W icursor sel.first}\n"
|
3372 |
|
|
"}\n"
|
3373 |
|
|
"bind Entry <Triple-1> {\n"
|
3374 |
|
|
"set tkPriv(selectMode) line\n"
|
3375 |
|
|
"tkEntryMouseSelect %W %x\n"
|
3376 |
|
|
"%W icursor 0\n"
|
3377 |
|
|
"}\n"
|
3378 |
|
|
"bind Entry <Shift-1> {\n"
|
3379 |
|
|
"set tkPriv(selectMode) char\n"
|
3380 |
|
|
"%W selection adjust @%x\n"
|
3381 |
|
|
"}\n"
|
3382 |
|
|
"bind Entry <Double-Shift-1>\011{\n"
|
3383 |
|
|
"set tkPriv(selectMode) word\n"
|
3384 |
|
|
"tkEntryMouseSelect %W %x\n"
|
3385 |
|
|
"}\n"
|
3386 |
|
|
"bind Entry <Triple-Shift-1>\011{\n"
|
3387 |
|
|
"set tkPriv(selectMode) line\n"
|
3388 |
|
|
"tkEntryMouseSelect %W %x\n"
|
3389 |
|
|
"}\n"
|
3390 |
|
|
"bind Entry <B1-Leave> {\n"
|
3391 |
|
|
"set tkPriv(x) %x\n"
|
3392 |
|
|
"tkEntryAutoScan %W\n"
|
3393 |
|
|
"}\n"
|
3394 |
|
|
"bind Entry <B1-Enter> {\n"
|
3395 |
|
|
"tkCancelRepeat\n"
|
3396 |
|
|
"}\n"
|
3397 |
|
|
"bind Entry <ButtonRelease-1> {\n"
|
3398 |
|
|
"tkCancelRepeat\n"
|
3399 |
|
|
"}\n"
|
3400 |
|
|
"bind Entry <Control-1> {\n"
|
3401 |
|
|
"%W icursor @%x\n"
|
3402 |
|
|
"}\n"
|
3403 |
|
|
"bind Entry <Left> {\n"
|
3404 |
|
|
"tkEntrySetCursor %W [expr {[%W index insert] - 1}]\n"
|
3405 |
|
|
"}\n"
|
3406 |
|
|
"bind Entry <Right> {\n"
|
3407 |
|
|
"tkEntrySetCursor %W [expr {[%W index insert] + 1}]\n"
|
3408 |
|
|
"}\n"
|
3409 |
|
|
"bind Entry <Shift-Left> {\n"
|
3410 |
|
|
"tkEntryKeySelect %W [expr {[%W index insert] - 1}]\n"
|
3411 |
|
|
"tkEntrySeeInsert %W\n"
|
3412 |
|
|
"}\n"
|
3413 |
|
|
"bind Entry <Shift-Right> {\n"
|
3414 |
|
|
"tkEntryKeySelect %W [expr {[%W index insert] + 1}]\n"
|
3415 |
|
|
"tkEntrySeeInsert %W\n"
|
3416 |
|
|
"}\n"
|
3417 |
|
|
"bind Entry <Control-Left> {\n"
|
3418 |
|
|
"tkEntrySetCursor %W [tkEntryPreviousWord %W insert]\n"
|
3419 |
|
|
"}\n"
|
3420 |
|
|
"bind Entry <Control-Right> {\n"
|
3421 |
|
|
"tkEntrySetCursor %W [tkEntryNextWord %W insert]\n"
|
3422 |
|
|
"}\n"
|
3423 |
|
|
"bind Entry <Shift-Control-Left> {\n"
|
3424 |
|
|
"tkEntryKeySelect %W [tkEntryPreviousWord %W insert]\n"
|
3425 |
|
|
"tkEntrySeeInsert %W\n"
|
3426 |
|
|
"}\n"
|
3427 |
|
|
"bind Entry <Shift-Control-Right> {\n"
|
3428 |
|
|
"tkEntryKeySelect %W [tkEntryNextWord %W insert]\n"
|
3429 |
|
|
"tkEntrySeeInsert %W\n"
|
3430 |
|
|
"}\n"
|
3431 |
|
|
"bind Entry <Home> {\n"
|
3432 |
|
|
"tkEntrySetCursor %W 0\n"
|
3433 |
|
|
"}\n"
|
3434 |
|
|
"bind Entry <Shift-Home> {\n"
|
3435 |
|
|
"tkEntryKeySelect %W 0\n"
|
3436 |
|
|
"tkEntrySeeInsert %W\n"
|
3437 |
|
|
"}\n"
|
3438 |
|
|
"bind Entry <End> {\n"
|
3439 |
|
|
"tkEntrySetCursor %W end\n"
|
3440 |
|
|
"}\n"
|
3441 |
|
|
"bind Entry <Shift-End> {\n"
|
3442 |
|
|
"tkEntryKeySelect %W end\n"
|
3443 |
|
|
"tkEntrySeeInsert %W\n"
|
3444 |
|
|
"}\n"
|
3445 |
|
|
"bind Entry <Delete> {\n"
|
3446 |
|
|
"if {[%W selection present]} {\n"
|
3447 |
|
|
"%W delete sel.first sel.last\n"
|
3448 |
|
|
"} else {\n"
|
3449 |
|
|
"%W delete insert\n"
|
3450 |
|
|
"}\n"
|
3451 |
|
|
"}\n"
|
3452 |
|
|
"bind Entry <BackSpace> {\n"
|
3453 |
|
|
"tkEntryBackspace %W\n"
|
3454 |
|
|
"}\n"
|
3455 |
|
|
"bind Entry <Control-space> {\n"
|
3456 |
|
|
"%W selection from insert\n"
|
3457 |
|
|
"}\n"
|
3458 |
|
|
"bind Entry <Select> {\n"
|
3459 |
|
|
"%W selection from insert\n"
|
3460 |
|
|
"}\n"
|
3461 |
|
|
"bind Entry <Control-Shift-space> {\n"
|
3462 |
|
|
"%W selection adjust insert\n"
|
3463 |
|
|
"}\n"
|
3464 |
|
|
"bind Entry <Shift-Select> {\n"
|
3465 |
|
|
"%W selection adjust insert\n"
|
3466 |
|
|
"}\n"
|
3467 |
|
|
"bind Entry <Control-slash> {\n"
|
3468 |
|
|
"%W selection range 0 end\n"
|
3469 |
|
|
"}\n"
|
3470 |
|
|
"bind Entry <Control-backslash> {\n"
|
3471 |
|
|
"%W selection clear\n"
|
3472 |
|
|
"}\n"
|
3473 |
|
|
"bind Entry <KeyPress> {\n"
|
3474 |
|
|
"tkEntryInsert %W %A\n"
|
3475 |
|
|
"}\n"
|
3476 |
|
|
"bind Entry <Alt-KeyPress> {# nothing}\n"
|
3477 |
|
|
"bind Entry <Meta-KeyPress> {# nothing}\n"
|
3478 |
|
|
"bind Entry <Control-KeyPress> {# nothing}\n"
|
3479 |
|
|
"bind Entry <Escape> {# nothing}\n"
|
3480 |
|
|
"bind Entry <Return> {# nothing}\n"
|
3481 |
|
|
"bind Entry <KP_Enter> {# nothing}\n"
|
3482 |
|
|
"bind Entry <Tab> {# nothing}\n"
|
3483 |
|
|
"if {[string equal $tcl_platform(platform) \"macintosh\"]} {\n"
|
3484 |
|
|
"bind Entry <Command-KeyPress> {# nothing}\n"
|
3485 |
|
|
"}\n"
|
3486 |
|
|
"if {[string compare $tcl_platform(platform) \"windows\"]} {\n"
|
3487 |
|
|
"bind Entry <Insert> {\n"
|
3488 |
|
|
"catch {tkEntryInsert %W [selection get -displayof %W]}\n"
|
3489 |
|
|
"}\n"
|
3490 |
|
|
"}\n"
|
3491 |
|
|
"bind Entry <Control-a> {\n"
|
3492 |
|
|
"if {!$tk_strictMotif} {\n"
|
3493 |
|
|
"tkEntrySetCursor %W 0\n"
|
3494 |
|
|
"}\n"
|
3495 |
|
|
"}\n"
|
3496 |
|
|
"bind Entry <Control-b> {\n"
|
3497 |
|
|
"if {!$tk_strictMotif} {\n"
|
3498 |
|
|
"tkEntrySetCursor %W [expr {[%W index insert] - 1}]\n"
|
3499 |
|
|
"}\n"
|
3500 |
|
|
"}\n"
|
3501 |
|
|
"bind Entry <Control-d> {\n"
|
3502 |
|
|
"if {!$tk_strictMotif} {\n"
|
3503 |
|
|
"%W delete insert\n"
|
3504 |
|
|
"}\n"
|
3505 |
|
|
"}\n"
|
3506 |
|
|
"bind Entry <Control-e> {\n"
|
3507 |
|
|
"if {!$tk_strictMotif} {\n"
|
3508 |
|
|
"tkEntrySetCursor %W end\n"
|
3509 |
|
|
"}\n"
|
3510 |
|
|
"}\n"
|
3511 |
|
|
"bind Entry <Control-f> {\n"
|
3512 |
|
|
"if {!$tk_strictMotif} {\n"
|
3513 |
|
|
"tkEntrySetCursor %W [expr {[%W index insert] + 1}]\n"
|
3514 |
|
|
"}\n"
|
3515 |
|
|
"}\n"
|
3516 |
|
|
"bind Entry <Control-h> {\n"
|
3517 |
|
|
"if {!$tk_strictMotif} {\n"
|
3518 |
|
|
"tkEntryBackspace %W\n"
|
3519 |
|
|
"}\n"
|
3520 |
|
|
"}\n"
|
3521 |
|
|
"bind Entry <Control-k> {\n"
|
3522 |
|
|
"if {!$tk_strictMotif} {\n"
|
3523 |
|
|
"%W delete insert end\n"
|
3524 |
|
|
"}\n"
|
3525 |
|
|
"}\n"
|
3526 |
|
|
"bind Entry <Control-t> {\n"
|
3527 |
|
|
"if {!$tk_strictMotif} {\n"
|
3528 |
|
|
"tkEntryTranspose %W\n"
|
3529 |
|
|
"}\n"
|
3530 |
|
|
"}\n"
|
3531 |
|
|
"bind Entry <Meta-b> {\n"
|
3532 |
|
|
"if {!$tk_strictMotif} {\n"
|
3533 |
|
|
"tkEntrySetCursor %W [tkEntryPreviousWord %W insert]\n"
|
3534 |
|
|
"}\n"
|
3535 |
|
|
"}\n"
|
3536 |
|
|
"bind Entry <Meta-d> {\n"
|
3537 |
|
|
"if {!$tk_strictMotif} {\n"
|
3538 |
|
|
"%W delete insert [tkEntryNextWord %W insert]\n"
|
3539 |
|
|
"}\n"
|
3540 |
|
|
"}\n"
|
3541 |
|
|
"bind Entry <Meta-f> {\n"
|
3542 |
|
|
"if {!$tk_strictMotif} {\n"
|
3543 |
|
|
"tkEntrySetCursor %W [tkEntryNextWord %W insert]\n"
|
3544 |
|
|
"}\n"
|
3545 |
|
|
"}\n"
|
3546 |
|
|
"bind Entry <Meta-BackSpace> {\n"
|
3547 |
|
|
"if {!$tk_strictMotif} {\n"
|
3548 |
|
|
"%W delete [tkEntryPreviousWord %W insert] insert\n"
|
3549 |
|
|
"}\n"
|
3550 |
|
|
"}\n"
|
3551 |
|
|
"bind Entry <Meta-Delete> {\n"
|
3552 |
|
|
"if {!$tk_strictMotif} {\n"
|
3553 |
|
|
"%W delete [tkEntryPreviousWord %W insert] insert\n"
|
3554 |
|
|
"}\n"
|
3555 |
|
|
"}\n"
|
3556 |
|
|
"bind Entry <2> {\n"
|
3557 |
|
|
"if {!$tk_strictMotif} {\n"
|
3558 |
|
|
"%W scan mark %x\n"
|
3559 |
|
|
"set tkPriv(x) %x\n"
|
3560 |
|
|
"set tkPriv(y) %y\n"
|
3561 |
|
|
"set tkPriv(mouseMoved) 0\n"
|
3562 |
|
|
"}\n"
|
3563 |
|
|
"}\n"
|
3564 |
|
|
"bind Entry <B2-Motion> {\n"
|
3565 |
|
|
"if {!$tk_strictMotif} {\n"
|
3566 |
|
|
"if {abs(%x-$tkPriv(x)) > 2} {\n"
|
3567 |
|
|
"set tkPriv(mouseMoved) 1\n"
|
3568 |
|
|
"}\n"
|
3569 |
|
|
"%W scan dragto %x\n"
|
3570 |
|
|
"}\n"
|
3571 |
|
|
"}\n"
|
3572 |
|
|
"proc tkEntryClosestGap {w x} {\n"
|
3573 |
|
|
"set pos [$w index @$x]\n"
|
3574 |
|
|
"set bbox [$w bbox $pos]\n"
|
3575 |
|
|
"if {($x - [lindex $bbox 0]) < ([lindex $bbox 2]/2)} {\n"
|
3576 |
|
|
"return $pos\n"
|
3577 |
|
|
"}\n"
|
3578 |
|
|
"incr pos\n"
|
3579 |
|
|
"}\n"
|
3580 |
|
|
"proc tkEntryButton1 {w x} {\n"
|
3581 |
|
|
"global tkPriv\n"
|
3582 |
|
|
"set tkPriv(selectMode) char\n"
|
3583 |
|
|
"set tkPriv(mouseMoved) 0\n"
|
3584 |
|
|
"set tkPriv(pressX) $x\n"
|
3585 |
|
|
"$w icursor [tkEntryClosestGap $w $x]\n"
|
3586 |
|
|
"$w selection from insert\n"
|
3587 |
|
|
"if {[string equal [$w cget -state] \"normal\"]} {focus $w}\n"
|
3588 |
|
|
"}\n"
|
3589 |
|
|
"proc tkEntryMouseSelect {w x} {\n"
|
3590 |
|
|
"global tkPriv\n"
|
3591 |
|
|
"set cur [tkEntryClosestGap $w $x]\n"
|
3592 |
|
|
"set anchor [$w index anchor]\n"
|
3593 |
|
|
"if {($cur != $anchor) || (abs($tkPriv(pressX) - $x) >= 3)} {\n"
|
3594 |
|
|
"set tkPriv(mouseMoved) 1\n"
|
3595 |
|
|
"}\n"
|
3596 |
|
|
"switch $tkPriv(selectMode) {\n"
|
3597 |
|
|
"char {\n"
|
3598 |
|
|
"if {$tkPriv(mouseMoved)} {\n"
|
3599 |
|
|
"if {$cur < $anchor} {\n"
|
3600 |
|
|
"$w selection range $cur $anchor\n"
|
3601 |
|
|
"} elseif {$cur > $anchor} {\n"
|
3602 |
|
|
"$w selection range $anchor $cur\n"
|
3603 |
|
|
"} else {\n"
|
3604 |
|
|
"$w selection clear\n"
|
3605 |
|
|
"}\n"
|
3606 |
|
|
"}\n"
|
3607 |
|
|
"}\n"
|
3608 |
|
|
"word {\n"
|
3609 |
|
|
"if {$cur < [$w index anchor]} {\n"
|
3610 |
|
|
"set before [tcl_wordBreakBefore [$w get] $cur]\n"
|
3611 |
|
|
"set after [tcl_wordBreakAfter [$w get] [expr {$anchor-1}]]\n"
|
3612 |
|
|
"} else {\n"
|
3613 |
|
|
"set before [tcl_wordBreakBefore [$w get] $anchor]\n"
|
3614 |
|
|
"set after [tcl_wordBreakAfter [$w get] [expr {$cur - 1}]]\n"
|
3615 |
|
|
"}\n"
|
3616 |
|
|
"if {$before < 0} {\n"
|
3617 |
|
|
"set before 0\n"
|
3618 |
|
|
"}\n"
|
3619 |
|
|
"if {$after < 0} {\n"
|
3620 |
|
|
"set after end\n"
|
3621 |
|
|
"}\n"
|
3622 |
|
|
"$w selection range $before $after\n"
|
3623 |
|
|
"}\n"
|
3624 |
|
|
"line {\n"
|
3625 |
|
|
"$w selection range 0 end\n"
|
3626 |
|
|
"}\n"
|
3627 |
|
|
"}\n"
|
3628 |
|
|
"update idletasks\n"
|
3629 |
|
|
"}\n"
|
3630 |
|
|
"proc tkEntryPaste {w x} {\n"
|
3631 |
|
|
"global tkPriv\n"
|
3632 |
|
|
"$w icursor [tkEntryClosestGap $w $x]\n"
|
3633 |
|
|
"catch {$w insert insert [selection get -displayof $w]}\n"
|
3634 |
|
|
"if {[string equal [$w cget -state] \"normal\"]} {focus $w}\n"
|
3635 |
|
|
"}\n"
|
3636 |
|
|
"proc tkEntryAutoScan {w} {\n"
|
3637 |
|
|
"global tkPriv\n"
|
3638 |
|
|
"set x $tkPriv(x)\n"
|
3639 |
|
|
"if {![winfo exists $w]} return\n"
|
3640 |
|
|
"if {$x >= [winfo width $w]} {\n"
|
3641 |
|
|
"$w xview scroll 2 units\n"
|
3642 |
|
|
"tkEntryMouseSelect $w $x\n"
|
3643 |
|
|
"} elseif {$x < 0} {\n"
|
3644 |
|
|
"$w xview scroll -2 units\n"
|
3645 |
|
|
"tkEntryMouseSelect $w $x\n"
|
3646 |
|
|
"}\n"
|
3647 |
|
|
"set tkPriv(afterId) [after 50 [list tkEntryAutoScan $w]]\n"
|
3648 |
|
|
"}\n"
|
3649 |
|
|
"proc tkEntryKeySelect {w new} {\n"
|
3650 |
|
|
"if {![$w selection present]} {\n"
|
3651 |
|
|
"$w selection from insert\n"
|
3652 |
|
|
"$w selection to $new\n"
|
3653 |
|
|
"} else {\n"
|
3654 |
|
|
"$w selection adjust $new\n"
|
3655 |
|
|
"}\n"
|
3656 |
|
|
"$w icursor $new\n"
|
3657 |
|
|
"}\n"
|
3658 |
|
|
"proc tkEntryInsert {w s} {\n"
|
3659 |
|
|
"if {[string equal $s \"\"]} {\n"
|
3660 |
|
|
"return\n"
|
3661 |
|
|
"}\n"
|
3662 |
|
|
"catch {\n"
|
3663 |
|
|
"set insert [$w index insert]\n"
|
3664 |
|
|
"if {([$w index sel.first] <= $insert)\n"
|
3665 |
|
|
"&& ([$w index sel.last] >= $insert)} {\n"
|
3666 |
|
|
"$w delete sel.first sel.last\n"
|
3667 |
|
|
"}\n"
|
3668 |
|
|
"}\n"
|
3669 |
|
|
"$w insert insert $s\n"
|
3670 |
|
|
"tkEntrySeeInsert $w\n"
|
3671 |
|
|
"}\n"
|
3672 |
|
|
"proc tkEntryBackspace w {\n"
|
3673 |
|
|
"if {[$w selection present]} {\n"
|
3674 |
|
|
"$w delete sel.first sel.last\n"
|
3675 |
|
|
"} else {\n"
|
3676 |
|
|
"set x [expr {[$w index insert] - 1}]\n"
|
3677 |
|
|
"if {$x >= 0} {$w delete $x}\n"
|
3678 |
|
|
"if {[$w index @0] >= [$w index insert]} {\n"
|
3679 |
|
|
"set range [$w xview]\n"
|
3680 |
|
|
"set left [lindex $range 0]\n"
|
3681 |
|
|
"set right [lindex $range 1]\n"
|
3682 |
|
|
"$w xview moveto [expr {$left - ($right - $left)/2.0}]\n"
|
3683 |
|
|
"}\n"
|
3684 |
|
|
"}\n"
|
3685 |
|
|
"}\n"
|
3686 |
|
|
"proc tkEntrySeeInsert w {\n"
|
3687 |
|
|
"set c [$w index insert]\n"
|
3688 |
|
|
"if {($c < [$w index @0]) || ($c > [$w index @[winfo width $w]])} {\n"
|
3689 |
|
|
"$w xview $c\n"
|
3690 |
|
|
"}\n"
|
3691 |
|
|
"}\n"
|
3692 |
|
|
"proc tkEntrySetCursor {w pos} {\n"
|
3693 |
|
|
"$w icursor $pos\n"
|
3694 |
|
|
"$w selection clear\n"
|
3695 |
|
|
"tkEntrySeeInsert $w\n"
|
3696 |
|
|
"}\n"
|
3697 |
|
|
"proc tkEntryTranspose w {\n"
|
3698 |
|
|
"set i [$w index insert]\n"
|
3699 |
|
|
"if {$i < [$w index end]} {\n"
|
3700 |
|
|
"incr i\n"
|
3701 |
|
|
"}\n"
|
3702 |
|
|
"set first [expr {$i-2}]\n"
|
3703 |
|
|
"if {$first < 0} {\n"
|
3704 |
|
|
"return\n"
|
3705 |
|
|
"}\n"
|
3706 |
|
|
"set new [string index [$w get] [expr {$i-1}]][string index [$w get] $first]\n"
|
3707 |
|
|
"$w delete $first $i\n"
|
3708 |
|
|
"$w insert insert $new\n"
|
3709 |
|
|
"tkEntrySeeInsert $w\n"
|
3710 |
|
|
"}\n"
|
3711 |
|
|
"if {[string equal $tcl_platform(platform) \"windows\"]} {\n"
|
3712 |
|
|
"proc tkEntryNextWord {w start} {\n"
|
3713 |
|
|
"set pos [tcl_endOfWord [$w get] [$w index $start]]\n"
|
3714 |
|
|
"if {$pos >= 0} {\n"
|
3715 |
|
|
"set pos [tcl_startOfNextWord [$w get] $pos]\n"
|
3716 |
|
|
"}\n"
|
3717 |
|
|
"if {$pos < 0} {\n"
|
3718 |
|
|
"return end\n"
|
3719 |
|
|
"}\n"
|
3720 |
|
|
"return $pos\n"
|
3721 |
|
|
"}\n"
|
3722 |
|
|
"} else {\n"
|
3723 |
|
|
"proc tkEntryNextWord {w start} {\n"
|
3724 |
|
|
"set pos [tcl_endOfWord [$w get] [$w index $start]]\n"
|
3725 |
|
|
"if {$pos < 0} {\n"
|
3726 |
|
|
"return end\n"
|
3727 |
|
|
"}\n"
|
3728 |
|
|
"return $pos\n"
|
3729 |
|
|
"}\n"
|
3730 |
|
|
"}\n"
|
3731 |
|
|
"proc tkEntryPreviousWord {w start} {\n"
|
3732 |
|
|
"set pos [tcl_startOfPreviousWord [$w get] [$w index $start]]\n"
|
3733 |
|
|
"if {$pos < 0} {\n"
|
3734 |
|
|
"return 0\n"
|
3735 |
|
|
"}\n"
|
3736 |
|
|
"return $pos\n"
|
3737 |
|
|
"}\n"
|
3738 |
|
|
"proc tkEntryGetSelection {w} {\n"
|
3739 |
|
|
"set entryString [string range [$w get] [$w index sel.first] \\\n"
|
3740 |
|
|
"\011 [expr {[$w index sel.last] - 1}]]\n"
|
3741 |
|
|
"if {[string compare [$w cget -show] \"\"]} {\n"
|
3742 |
|
|
"regsub -all . $entryString [string index [$w cget -show] 0] entryString\n"
|
3743 |
|
|
"}\n"
|
3744 |
|
|
"return $entryString\n"
|
3745 |
|
|
"}\n"
|
3746 |
|
|
;
|
3747 |
|
|
static char Et_zFile15[] =
|
3748 |
|
|
"proc tk_focusNext w {\n"
|
3749 |
|
|
"set cur $w\n"
|
3750 |
|
|
"while {1} {\n"
|
3751 |
|
|
"set parent $cur\n"
|
3752 |
|
|
"set children [winfo children $cur]\n"
|
3753 |
|
|
"set i -1\n"
|
3754 |
|
|
"while {1} {\n"
|
3755 |
|
|
"incr i\n"
|
3756 |
|
|
"if {$i < [llength $children]} {\n"
|
3757 |
|
|
"set cur [lindex $children $i]\n"
|
3758 |
|
|
"if {[string equal [winfo toplevel $cur] $cur]} {\n"
|
3759 |
|
|
"continue\n"
|
3760 |
|
|
"} else {\n"
|
3761 |
|
|
"break\n"
|
3762 |
|
|
"}\n"
|
3763 |
|
|
"}\n"
|
3764 |
|
|
"set cur $parent\n"
|
3765 |
|
|
"if {[string equal [winfo toplevel $cur] $cur]} {\n"
|
3766 |
|
|
"break\n"
|
3767 |
|
|
"}\n"
|
3768 |
|
|
"set parent [winfo parent $parent]\n"
|
3769 |
|
|
"set children [winfo children $parent]\n"
|
3770 |
|
|
"set i [lsearch -exact $children $cur]\n"
|
3771 |
|
|
"}\n"
|
3772 |
|
|
"if {[string equal $w $cur] || [tkFocusOK $cur]} {\n"
|
3773 |
|
|
"return $cur\n"
|
3774 |
|
|
"}\n"
|
3775 |
|
|
"}\n"
|
3776 |
|
|
"}\n"
|
3777 |
|
|
"proc tk_focusPrev w {\n"
|
3778 |
|
|
"set cur $w\n"
|
3779 |
|
|
"while {1} {\n"
|
3780 |
|
|
"if {[string equal [winfo toplevel $cur] $cur]} {\n"
|
3781 |
|
|
"set parent $cur\n"
|
3782 |
|
|
"set children [winfo children $cur]\n"
|
3783 |
|
|
"set i [llength $children]\n"
|
3784 |
|
|
"} else {\n"
|
3785 |
|
|
"set parent [winfo parent $cur]\n"
|
3786 |
|
|
"set children [winfo children $parent]\n"
|
3787 |
|
|
"set i [lsearch -exact $children $cur]\n"
|
3788 |
|
|
"}\n"
|
3789 |
|
|
"while {$i > 0} {\n"
|
3790 |
|
|
"incr i -1\n"
|
3791 |
|
|
"set cur [lindex $children $i]\n"
|
3792 |
|
|
"if {[string equal [winfo toplevel $cur] $cur]} {\n"
|
3793 |
|
|
"continue\n"
|
3794 |
|
|
"}\n"
|
3795 |
|
|
"set parent $cur\n"
|
3796 |
|
|
"set children [winfo children $parent]\n"
|
3797 |
|
|
"set i [llength $children]\n"
|
3798 |
|
|
"}\n"
|
3799 |
|
|
"set cur $parent\n"
|
3800 |
|
|
"if {[string equal $w $cur] || [tkFocusOK $cur]} {\n"
|
3801 |
|
|
"return $cur\n"
|
3802 |
|
|
"}\n"
|
3803 |
|
|
"}\n"
|
3804 |
|
|
"}\n"
|
3805 |
|
|
"proc tkFocusOK w {\n"
|
3806 |
|
|
"set code [catch {$w cget -takefocus} value]\n"
|
3807 |
|
|
"if {($code == 0) && [string compare $value \"\"]} {\n"
|
3808 |
|
|
"if {$value == 0} {\n"
|
3809 |
|
|
"return 0\n"
|
3810 |
|
|
"} elseif {$value == 1} {\n"
|
3811 |
|
|
"return [winfo viewable $w]\n"
|
3812 |
|
|
"} else {\n"
|
3813 |
|
|
"set value [uplevel #0 [list $value $w]]\n"
|
3814 |
|
|
"if {[string compare $value \"\"]} {\n"
|
3815 |
|
|
"return $value\n"
|
3816 |
|
|
"}\n"
|
3817 |
|
|
"}\n"
|
3818 |
|
|
"}\n"
|
3819 |
|
|
"if {![winfo viewable $w]} {\n"
|
3820 |
|
|
"return 0\n"
|
3821 |
|
|
"}\n"
|
3822 |
|
|
"set code [catch {$w cget -state} value]\n"
|
3823 |
|
|
"if {($code == 0) && [string equal $value \"disabled\"]} {\n"
|
3824 |
|
|
"return 0\n"
|
3825 |
|
|
"}\n"
|
3826 |
|
|
"regexp Key|Focus \"[bind $w] [bind [winfo class $w]]\"\n"
|
3827 |
|
|
"}\n"
|
3828 |
|
|
"proc tk_focusFollowsMouse {} {\n"
|
3829 |
|
|
"set old [bind all <Enter>]\n"
|
3830 |
|
|
"set script {\n"
|
3831 |
|
|
"if {[string equal \"%d\" \"NotifyAncestor\"] \\\n"
|
3832 |
|
|
"\011\011|| [string equal \"%d\" \"NotifyNonlinear\"] \\\n"
|
3833 |
|
|
"\011\011|| [string equal \"%d\" \"NotifyInferior\"]} {\n"
|
3834 |
|
|
"if {[tkFocusOK %W]} {\n"
|
3835 |
|
|
"focus %W\n"
|
3836 |
|
|
"}\n"
|
3837 |
|
|
"}\n"
|
3838 |
|
|
"}\n"
|
3839 |
|
|
"if {[string compare $old \"\"]} {\n"
|
3840 |
|
|
"bind all <Enter> \"$old; $script\"\n"
|
3841 |
|
|
"} else {\n"
|
3842 |
|
|
"bind all <Enter> $script\n"
|
3843 |
|
|
"}\n"
|
3844 |
|
|
"}\n"
|
3845 |
|
|
;
|
3846 |
|
|
static char Et_zFile16[] =
|
3847 |
|
|
"bind Listbox <1> {\n"
|
3848 |
|
|
"if {[winfo exists %W]} {\n"
|
3849 |
|
|
"tkListboxBeginSelect %W [%W index @%x,%y]\n"
|
3850 |
|
|
"}\n"
|
3851 |
|
|
"}\n"
|
3852 |
|
|
"bind Listbox <Double-1> {\n"
|
3853 |
|
|
"}\n"
|
3854 |
|
|
"bind Listbox <B1-Motion> {\n"
|
3855 |
|
|
"set tkPriv(x) %x\n"
|
3856 |
|
|
"set tkPriv(y) %y\n"
|
3857 |
|
|
"tkListboxMotion %W [%W index @%x,%y]\n"
|
3858 |
|
|
"}\n"
|
3859 |
|
|
"bind Listbox <ButtonRelease-1> {\n"
|
3860 |
|
|
"tkCancelRepeat\n"
|
3861 |
|
|
"%W activate @%x,%y\n"
|
3862 |
|
|
"}\n"
|
3863 |
|
|
"bind Listbox <Shift-1> {\n"
|
3864 |
|
|
"tkListboxBeginExtend %W [%W index @%x,%y]\n"
|
3865 |
|
|
"}\n"
|
3866 |
|
|
"bind Listbox <Control-1> {\n"
|
3867 |
|
|
"tkListboxBeginToggle %W [%W index @%x,%y]\n"
|
3868 |
|
|
"}\n"
|
3869 |
|
|
"bind Listbox <B1-Leave> {\n"
|
3870 |
|
|
"set tkPriv(x) %x\n"
|
3871 |
|
|
"set tkPriv(y) %y\n"
|
3872 |
|
|
"tkListboxAutoScan %W\n"
|
3873 |
|
|
"}\n"
|
3874 |
|
|
"bind Listbox <B1-Enter> {\n"
|
3875 |
|
|
"tkCancelRepeat\n"
|
3876 |
|
|
"}\n"
|
3877 |
|
|
"bind Listbox <Up> {\n"
|
3878 |
|
|
"tkListboxUpDown %W -1\n"
|
3879 |
|
|
"}\n"
|
3880 |
|
|
"bind Listbox <Shift-Up> {\n"
|
3881 |
|
|
"tkListboxExtendUpDown %W -1\n"
|
3882 |
|
|
"}\n"
|
3883 |
|
|
"bind Listbox <Down> {\n"
|
3884 |
|
|
"tkListboxUpDown %W 1\n"
|
3885 |
|
|
"}\n"
|
3886 |
|
|
"bind Listbox <Shift-Down> {\n"
|
3887 |
|
|
"tkListboxExtendUpDown %W 1\n"
|
3888 |
|
|
"}\n"
|
3889 |
|
|
"bind Listbox <Left> {\n"
|
3890 |
|
|
"%W xview scroll -1 units\n"
|
3891 |
|
|
"}\n"
|
3892 |
|
|
"bind Listbox <Control-Left> {\n"
|
3893 |
|
|
"%W xview scroll -1 pages\n"
|
3894 |
|
|
"}\n"
|
3895 |
|
|
"bind Listbox <Right> {\n"
|
3896 |
|
|
"%W xview scroll 1 units\n"
|
3897 |
|
|
"}\n"
|
3898 |
|
|
"bind Listbox <Control-Right> {\n"
|
3899 |
|
|
"%W xview scroll 1 pages\n"
|
3900 |
|
|
"}\n"
|
3901 |
|
|
"bind Listbox <Prior> {\n"
|
3902 |
|
|
"%W yview scroll -1 pages\n"
|
3903 |
|
|
"%W activate @0,0\n"
|
3904 |
|
|
"}\n"
|
3905 |
|
|
"bind Listbox <Next> {\n"
|
3906 |
|
|
"%W yview scroll 1 pages\n"
|
3907 |
|
|
"%W activate @0,0\n"
|
3908 |
|
|
"}\n"
|
3909 |
|
|
"bind Listbox <Control-Prior> {\n"
|
3910 |
|
|
"%W xview scroll -1 pages\n"
|
3911 |
|
|
"}\n"
|
3912 |
|
|
"bind Listbox <Control-Next> {\n"
|
3913 |
|
|
"%W xview scroll 1 pages\n"
|
3914 |
|
|
"}\n"
|
3915 |
|
|
"bind Listbox <Home> {\n"
|
3916 |
|
|
"%W xview moveto 0\n"
|
3917 |
|
|
"}\n"
|
3918 |
|
|
"bind Listbox <End> {\n"
|
3919 |
|
|
"%W xview moveto 1\n"
|
3920 |
|
|
"}\n"
|
3921 |
|
|
"bind Listbox <Control-Home> {\n"
|
3922 |
|
|
"%W activate 0\n"
|
3923 |
|
|
"%W see 0\n"
|
3924 |
|
|
"%W selection clear 0 end\n"
|
3925 |
|
|
"%W selection set 0\n"
|
3926 |
|
|
"event generate %W <<ListboxSelect>>\n"
|
3927 |
|
|
"}\n"
|
3928 |
|
|
"bind Listbox <Shift-Control-Home> {\n"
|
3929 |
|
|
"tkListboxDataExtend %W 0\n"
|
3930 |
|
|
"}\n"
|
3931 |
|
|
"bind Listbox <Control-End> {\n"
|
3932 |
|
|
"%W activate end\n"
|
3933 |
|
|
"%W see end\n"
|
3934 |
|
|
"%W selection clear 0 end\n"
|
3935 |
|
|
"%W selection set end\n"
|
3936 |
|
|
"event generate %W <<ListboxSelect>>\n"
|
3937 |
|
|
"}\n"
|
3938 |
|
|
"bind Listbox <Shift-Control-End> {\n"
|
3939 |
|
|
"tkListboxDataExtend %W [%W index end]\n"
|
3940 |
|
|
"}\n"
|
3941 |
|
|
"bind Listbox <<Copy>> {\n"
|
3942 |
|
|
"if {[string equal [selection own -displayof %W] \"%W\"]} {\n"
|
3943 |
|
|
"clipboard clear -displayof %W\n"
|
3944 |
|
|
"clipboard append -displayof %W [selection get -displayof %W]\n"
|
3945 |
|
|
"}\n"
|
3946 |
|
|
"}\n"
|
3947 |
|
|
"bind Listbox <space> {\n"
|
3948 |
|
|
"tkListboxBeginSelect %W [%W index active]\n"
|
3949 |
|
|
"}\n"
|
3950 |
|
|
"bind Listbox <Select> {\n"
|
3951 |
|
|
"tkListboxBeginSelect %W [%W index active]\n"
|
3952 |
|
|
"}\n"
|
3953 |
|
|
"bind Listbox <Control-Shift-space> {\n"
|
3954 |
|
|
"tkListboxBeginExtend %W [%W index active]\n"
|
3955 |
|
|
"}\n"
|
3956 |
|
|
"bind Listbox <Shift-Select> {\n"
|
3957 |
|
|
"tkListboxBeginExtend %W [%W index active]\n"
|
3958 |
|
|
"}\n"
|
3959 |
|
|
"bind Listbox <Escape> {\n"
|
3960 |
|
|
"tkListboxCancel %W\n"
|
3961 |
|
|
"}\n"
|
3962 |
|
|
"bind Listbox <Control-slash> {\n"
|
3963 |
|
|
"tkListboxSelectAll %W\n"
|
3964 |
|
|
"}\n"
|
3965 |
|
|
"bind Listbox <Control-backslash> {\n"
|
3966 |
|
|
"if {[string compare [%W cget -selectmode] \"browse\"]} {\n"
|
3967 |
|
|
"%W selection clear 0 end\n"
|
3968 |
|
|
"event generate %W <<ListboxSelect>>\n"
|
3969 |
|
|
"}\n"
|
3970 |
|
|
"}\n"
|
3971 |
|
|
"bind Listbox <2> {\n"
|
3972 |
|
|
"%W scan mark %x %y\n"
|
3973 |
|
|
"}\n"
|
3974 |
|
|
"bind Listbox <B2-Motion> {\n"
|
3975 |
|
|
"%W scan dragto %x %y\n"
|
3976 |
|
|
"}\n"
|
3977 |
|
|
"bind Listbox <MouseWheel> {\n"
|
3978 |
|
|
"%W yview scroll [expr {- (%D / 120) * 4}] units\n"
|
3979 |
|
|
"}\n"
|
3980 |
|
|
"if {[string equal \"unix\" $tcl_platform(platform)]} {\n"
|
3981 |
|
|
"bind Listbox <4> {\n"
|
3982 |
|
|
"if {!$tk_strictMotif} {\n"
|
3983 |
|
|
"%W yview scroll -5 units\n"
|
3984 |
|
|
"}\n"
|
3985 |
|
|
"}\n"
|
3986 |
|
|
"bind Listbox <5> {\n"
|
3987 |
|
|
"if {!$tk_strictMotif} {\n"
|
3988 |
|
|
"%W yview scroll 5 units\n"
|
3989 |
|
|
"}\n"
|
3990 |
|
|
"}\n"
|
3991 |
|
|
"}\n"
|
3992 |
|
|
"proc tkListboxBeginSelect {w el} {\n"
|
3993 |
|
|
"global tkPriv\n"
|
3994 |
|
|
"if {[string equal [$w cget -selectmode] \"multiple\"]} {\n"
|
3995 |
|
|
"if {[$w selection includes $el]} {\n"
|
3996 |
|
|
"$w selection clear $el\n"
|
3997 |
|
|
"} else {\n"
|
3998 |
|
|
"$w selection set $el\n"
|
3999 |
|
|
"}\n"
|
4000 |
|
|
"} else {\n"
|
4001 |
|
|
"$w selection clear 0 end\n"
|
4002 |
|
|
"$w selection set $el\n"
|
4003 |
|
|
"$w selection anchor $el\n"
|
4004 |
|
|
"set tkPriv(listboxSelection) {}\n"
|
4005 |
|
|
"set tkPriv(listboxPrev) $el\n"
|
4006 |
|
|
"}\n"
|
4007 |
|
|
"event generate $w <<ListboxSelect>>\n"
|
4008 |
|
|
"}\n"
|
4009 |
|
|
"proc tkListboxMotion {w el} {\n"
|
4010 |
|
|
"global tkPriv\n"
|
4011 |
|
|
"if {$el == $tkPriv(listboxPrev)} {\n"
|
4012 |
|
|
"return\n"
|
4013 |
|
|
"}\n"
|
4014 |
|
|
"set anchor [$w index anchor]\n"
|
4015 |
|
|
"switch [$w cget -selectmode] {\n"
|
4016 |
|
|
"browse {\n"
|
4017 |
|
|
"$w selection clear 0 end\n"
|
4018 |
|
|
"$w selection set $el\n"
|
4019 |
|
|
"set tkPriv(listboxPrev) $el\n"
|
4020 |
|
|
"event generate $w <<ListboxSelect>>\n"
|
4021 |
|
|
"}\n"
|
4022 |
|
|
"extended {\n"
|
4023 |
|
|
"set i $tkPriv(listboxPrev)\n"
|
4024 |
|
|
"if {[string equal {} $i]} {\n"
|
4025 |
|
|
"set i $el\n"
|
4026 |
|
|
"$w selection set $el\n"
|
4027 |
|
|
"}\n"
|
4028 |
|
|
"if {[$w selection includes anchor]} {\n"
|
4029 |
|
|
"$w selection clear $i $el\n"
|
4030 |
|
|
"$w selection set anchor $el\n"
|
4031 |
|
|
"} else {\n"
|
4032 |
|
|
"$w selection clear $i $el\n"
|
4033 |
|
|
"$w selection clear anchor $el\n"
|
4034 |
|
|
"}\n"
|
4035 |
|
|
"if {![info exists tkPriv(listboxSelection)]} {\n"
|
4036 |
|
|
"set tkPriv(listboxSelection) [$w curselection]\n"
|
4037 |
|
|
"}\n"
|
4038 |
|
|
"while {($i < $el) && ($i < $anchor)} {\n"
|
4039 |
|
|
"if {[lsearch $tkPriv(listboxSelection) $i] >= 0} {\n"
|
4040 |
|
|
"$w selection set $i\n"
|
4041 |
|
|
"}\n"
|
4042 |
|
|
"incr i\n"
|
4043 |
|
|
"}\n"
|
4044 |
|
|
"while {($i > $el) && ($i > $anchor)} {\n"
|
4045 |
|
|
"if {[lsearch $tkPriv(listboxSelection) $i] >= 0} {\n"
|
4046 |
|
|
"$w selection set $i\n"
|
4047 |
|
|
"}\n"
|
4048 |
|
|
"incr i -1\n"
|
4049 |
|
|
"}\n"
|
4050 |
|
|
"set tkPriv(listboxPrev) $el\n"
|
4051 |
|
|
"event generate $w <<ListboxSelect>>\n"
|
4052 |
|
|
"}\n"
|
4053 |
|
|
"}\n"
|
4054 |
|
|
"}\n"
|
4055 |
|
|
"proc tkListboxBeginExtend {w el} {\n"
|
4056 |
|
|
"if {[string equal [$w cget -selectmode] \"extended\"]} {\n"
|
4057 |
|
|
"if {[$w selection includes anchor]} {\n"
|
4058 |
|
|
"tkListboxMotion $w $el\n"
|
4059 |
|
|
"} else {\n"
|
4060 |
|
|
"tkListboxBeginSelect $w $el\n"
|
4061 |
|
|
"}\n"
|
4062 |
|
|
"}\n"
|
4063 |
|
|
"}\n"
|
4064 |
|
|
"proc tkListboxBeginToggle {w el} {\n"
|
4065 |
|
|
"global tkPriv\n"
|
4066 |
|
|
"if {[string equal [$w cget -selectmode] \"extended\"]} {\n"
|
4067 |
|
|
"set tkPriv(listboxSelection) [$w curselection]\n"
|
4068 |
|
|
"set tkPriv(listboxPrev) $el\n"
|
4069 |
|
|
"$w selection anchor $el\n"
|
4070 |
|
|
"if {[$w selection includes $el]} {\n"
|
4071 |
|
|
"$w selection clear $el\n"
|
4072 |
|
|
"} else {\n"
|
4073 |
|
|
"$w selection set $el\n"
|
4074 |
|
|
"}\n"
|
4075 |
|
|
"event generate $w <<ListboxSelect>>\n"
|
4076 |
|
|
"}\n"
|
4077 |
|
|
"}\n"
|
4078 |
|
|
"proc tkListboxAutoScan {w} {\n"
|
4079 |
|
|
"global tkPriv\n"
|
4080 |
|
|
"if {![winfo exists $w]} return\n"
|
4081 |
|
|
"set x $tkPriv(x)\n"
|
4082 |
|
|
"set y $tkPriv(y)\n"
|
4083 |
|
|
"if {$y >= [winfo height $w]} {\n"
|
4084 |
|
|
"$w yview scroll 1 units\n"
|
4085 |
|
|
"} elseif {$y < 0} {\n"
|
4086 |
|
|
"$w yview scroll -1 units\n"
|
4087 |
|
|
"} elseif {$x >= [winfo width $w]} {\n"
|
4088 |
|
|
"$w xview scroll 2 units\n"
|
4089 |
|
|
"} elseif {$x < 0} {\n"
|
4090 |
|
|
"$w xview scroll -2 units\n"
|
4091 |
|
|
"} else {\n"
|
4092 |
|
|
"return\n"
|
4093 |
|
|
"}\n"
|
4094 |
|
|
"tkListboxMotion $w [$w index @$x,$y]\n"
|
4095 |
|
|
"set tkPriv(afterId) [after 50 [list tkListboxAutoScan $w]]\n"
|
4096 |
|
|
"}\n"
|
4097 |
|
|
"proc tkListboxUpDown {w amount} {\n"
|
4098 |
|
|
"global tkPriv\n"
|
4099 |
|
|
"$w activate [expr {[$w index active] + $amount}]\n"
|
4100 |
|
|
"$w see active\n"
|
4101 |
|
|
"switch [$w cget -selectmode] {\n"
|
4102 |
|
|
"browse {\n"
|
4103 |
|
|
"$w selection clear 0 end\n"
|
4104 |
|
|
"$w selection set active\n"
|
4105 |
|
|
"event generate $w <<ListboxSelect>>\n"
|
4106 |
|
|
"}\n"
|
4107 |
|
|
"extended {\n"
|
4108 |
|
|
"$w selection clear 0 end\n"
|
4109 |
|
|
"$w selection set active\n"
|
4110 |
|
|
"$w selection anchor active\n"
|
4111 |
|
|
"set tkPriv(listboxPrev) [$w index active]\n"
|
4112 |
|
|
"set tkPriv(listboxSelection) {}\n"
|
4113 |
|
|
"event generate $w <<ListboxSelect>>\n"
|
4114 |
|
|
"}\n"
|
4115 |
|
|
"}\n"
|
4116 |
|
|
"}\n"
|
4117 |
|
|
"proc tkListboxExtendUpDown {w amount} {\n"
|
4118 |
|
|
"if {[string compare [$w cget -selectmode] \"extended\"]} {\n"
|
4119 |
|
|
"return\n"
|
4120 |
|
|
"}\n"
|
4121 |
|
|
"set active [$w index active]\n"
|
4122 |
|
|
"if {![info exists tkPriv(listboxSelection)]} {\n"
|
4123 |
|
|
"global tkPriv\n"
|
4124 |
|
|
"$w selection set $active\n"
|
4125 |
|
|
"set tkPriv(listboxSelection) [$w curselection]\n"
|
4126 |
|
|
"}\n"
|
4127 |
|
|
"$w activate [expr {$active + $amount}]\n"
|
4128 |
|
|
"$w see active\n"
|
4129 |
|
|
"tkListboxMotion $w [$w index active]\n"
|
4130 |
|
|
"}\n"
|
4131 |
|
|
"proc tkListboxDataExtend {w el} {\n"
|
4132 |
|
|
"set mode [$w cget -selectmode]\n"
|
4133 |
|
|
"if {[string equal $mode \"extended\"]} {\n"
|
4134 |
|
|
"$w activate $el\n"
|
4135 |
|
|
"$w see $el\n"
|
4136 |
|
|
"if {[$w selection includes anchor]} {\n"
|
4137 |
|
|
"tkListboxMotion $w $el\n"
|
4138 |
|
|
"}\n"
|
4139 |
|
|
"} elseif {[string equal $mode \"multiple\"]} {\n"
|
4140 |
|
|
"$w activate $el\n"
|
4141 |
|
|
"$w see $el\n"
|
4142 |
|
|
"}\n"
|
4143 |
|
|
"}\n"
|
4144 |
|
|
"proc tkListboxCancel w {\n"
|
4145 |
|
|
"global tkPriv\n"
|
4146 |
|
|
"if {[string compare [$w cget -selectmode] \"extended\"]} {\n"
|
4147 |
|
|
"return\n"
|
4148 |
|
|
"}\n"
|
4149 |
|
|
"set first [$w index anchor]\n"
|
4150 |
|
|
"set last $tkPriv(listboxPrev)\n"
|
4151 |
|
|
"if { [string equal $last \"\"] } {\n"
|
4152 |
|
|
"return\n"
|
4153 |
|
|
"}\n"
|
4154 |
|
|
"if {$first > $last} {\n"
|
4155 |
|
|
"set tmp $first\n"
|
4156 |
|
|
"set first $last\n"
|
4157 |
|
|
"set last $tmp\n"
|
4158 |
|
|
"}\n"
|
4159 |
|
|
"$w selection clear $first $last\n"
|
4160 |
|
|
"while {$first <= $last} {\n"
|
4161 |
|
|
"if {[lsearch $tkPriv(listboxSelection) $first] >= 0} {\n"
|
4162 |
|
|
"$w selection set $first\n"
|
4163 |
|
|
"}\n"
|
4164 |
|
|
"incr first\n"
|
4165 |
|
|
"}\n"
|
4166 |
|
|
"event generate $w <<ListboxSelect>>\n"
|
4167 |
|
|
"}\n"
|
4168 |
|
|
"proc tkListboxSelectAll w {\n"
|
4169 |
|
|
"set mode [$w cget -selectmode]\n"
|
4170 |
|
|
"if {[string equal $mode \"single\"] || [string equal $mode \"browse\"]} {\n"
|
4171 |
|
|
"$w selection clear 0 end\n"
|
4172 |
|
|
"$w selection set active\n"
|
4173 |
|
|
"} else {\n"
|
4174 |
|
|
"$w selection set 0 end\n"
|
4175 |
|
|
"}\n"
|
4176 |
|
|
"event generate $w <<ListboxSelect>>\n"
|
4177 |
|
|
"}\n"
|
4178 |
|
|
;
|
4179 |
|
|
static char Et_zFile17[] =
|
4180 |
|
|
"bind Menubutton <FocusIn> {}\n"
|
4181 |
|
|
"bind Menubutton <Enter> {\n"
|
4182 |
|
|
"tkMbEnter %W\n"
|
4183 |
|
|
"}\n"
|
4184 |
|
|
"bind Menubutton <Leave> {\n"
|
4185 |
|
|
"tkMbLeave %W\n"
|
4186 |
|
|
"}\n"
|
4187 |
|
|
"bind Menubutton <1> {\n"
|
4188 |
|
|
"if {[string compare $tkPriv(inMenubutton) \"\"]} {\n"
|
4189 |
|
|
"tkMbPost $tkPriv(inMenubutton) %X %Y\n"
|
4190 |
|
|
"}\n"
|
4191 |
|
|
"}\n"
|
4192 |
|
|
"bind Menubutton <Motion> {\n"
|
4193 |
|
|
"tkMbMotion %W up %X %Y\n"
|
4194 |
|
|
"}\n"
|
4195 |
|
|
"bind Menubutton <B1-Motion> {\n"
|
4196 |
|
|
"tkMbMotion %W down %X %Y\n"
|
4197 |
|
|
"}\n"
|
4198 |
|
|
"bind Menubutton <ButtonRelease-1> {\n"
|
4199 |
|
|
"tkMbButtonUp %W\n"
|
4200 |
|
|
"}\n"
|
4201 |
|
|
"bind Menubutton <space> {\n"
|
4202 |
|
|
"tkMbPost %W\n"
|
4203 |
|
|
"tkMenuFirstEntry [%W cget -menu]\n"
|
4204 |
|
|
"}\n"
|
4205 |
|
|
"bind Menu <FocusIn> {}\n"
|
4206 |
|
|
"bind Menu <Enter> {\n"
|
4207 |
|
|
"set tkPriv(window) %W\n"
|
4208 |
|
|
"if {[string equal [%W cget -type] \"tearoff\"]} {\n"
|
4209 |
|
|
"if {[string compare \"%m\" \"NotifyUngrab\"]} {\n"
|
4210 |
|
|
"if {[string equal $tcl_platform(platform) \"unix\"]} {\n"
|
4211 |
|
|
"tk_menuSetFocus %W\n"
|
4212 |
|
|
"}\n"
|
4213 |
|
|
"}\n"
|
4214 |
|
|
"}\n"
|
4215 |
|
|
"tkMenuMotion %W %x %y %s\n"
|
4216 |
|
|
"}\n"
|
4217 |
|
|
"bind Menu <Leave> {\n"
|
4218 |
|
|
"tkMenuLeave %W %X %Y %s\n"
|
4219 |
|
|
"}\n"
|
4220 |
|
|
"bind Menu <Motion> {\n"
|
4221 |
|
|
"tkMenuMotion %W %x %y %s\n"
|
4222 |
|
|
"}\n"
|
4223 |
|
|
"bind Menu <ButtonPress> {\n"
|
4224 |
|
|
"tkMenuButtonDown %W\n"
|
4225 |
|
|
"}\n"
|
4226 |
|
|
"bind Menu <ButtonRelease> {\n"
|
4227 |
|
|
"tkMenuInvoke %W 1\n"
|
4228 |
|
|
"}\n"
|
4229 |
|
|
"bind Menu <space> {\n"
|
4230 |
|
|
"tkMenuInvoke %W 0\n"
|
4231 |
|
|
"}\n"
|
4232 |
|
|
"bind Menu <Return> {\n"
|
4233 |
|
|
"tkMenuInvoke %W 0\n"
|
4234 |
|
|
"}\n"
|
4235 |
|
|
"bind Menu <Escape> {\n"
|
4236 |
|
|
"tkMenuEscape %W\n"
|
4237 |
|
|
"}\n"
|
4238 |
|
|
"bind Menu <Left> {\n"
|
4239 |
|
|
"tkMenuLeftArrow %W\n"
|
4240 |
|
|
"}\n"
|
4241 |
|
|
"bind Menu <Right> {\n"
|
4242 |
|
|
"tkMenuRightArrow %W\n"
|
4243 |
|
|
"}\n"
|
4244 |
|
|
"bind Menu <Up> {\n"
|
4245 |
|
|
"tkMenuUpArrow %W\n"
|
4246 |
|
|
"}\n"
|
4247 |
|
|
"bind Menu <Down> {\n"
|
4248 |
|
|
"tkMenuDownArrow %W\n"
|
4249 |
|
|
"}\n"
|
4250 |
|
|
"bind Menu <KeyPress> {\n"
|
4251 |
|
|
"tkTraverseWithinMenu %W %A\n"
|
4252 |
|
|
"}\n"
|
4253 |
|
|
"if {[string equal $tcl_platform(platform) \"unix\"]} {\n"
|
4254 |
|
|
"bind all <Alt-KeyPress> {\n"
|
4255 |
|
|
"tkTraverseToMenu %W %A\n"
|
4256 |
|
|
"}\n"
|
4257 |
|
|
"bind all <F10> {\n"
|
4258 |
|
|
"tkFirstMenu %W\n"
|
4259 |
|
|
"}\n"
|
4260 |
|
|
"} else {\n"
|
4261 |
|
|
"bind Menubutton <Alt-KeyPress> {\n"
|
4262 |
|
|
"tkTraverseToMenu %W %A\n"
|
4263 |
|
|
"}\n"
|
4264 |
|
|
"bind Menubutton <F10> {\n"
|
4265 |
|
|
"tkFirstMenu %W\n"
|
4266 |
|
|
"}\n"
|
4267 |
|
|
"}\n"
|
4268 |
|
|
"proc tkMbEnter w {\n"
|
4269 |
|
|
"global tkPriv\n"
|
4270 |
|
|
"if {[string compare $tkPriv(inMenubutton) \"\"]} {\n"
|
4271 |
|
|
"tkMbLeave $tkPriv(inMenubutton)\n"
|
4272 |
|
|
"}\n"
|
4273 |
|
|
"set tkPriv(inMenubutton) $w\n"
|
4274 |
|
|
"if {[string compare [$w cget -state] \"disabled\"]} {\n"
|
4275 |
|
|
"$w configure -state active\n"
|
4276 |
|
|
"}\n"
|
4277 |
|
|
"}\n"
|
4278 |
|
|
"proc tkMbLeave w {\n"
|
4279 |
|
|
"global tkPriv\n"
|
4280 |
|
|
"set tkPriv(inMenubutton) {}\n"
|
4281 |
|
|
"if {![winfo exists $w]} {\n"
|
4282 |
|
|
"return\n"
|
4283 |
|
|
"}\n"
|
4284 |
|
|
"if {[string equal [$w cget -state] \"active\"]} {\n"
|
4285 |
|
|
"$w configure -state normal\n"
|
4286 |
|
|
"}\n"
|
4287 |
|
|
"}\n"
|
4288 |
|
|
"proc tkMbPost {w {x {}} {y {}}} {\n"
|
4289 |
|
|
"global tkPriv errorInfo\n"
|
4290 |
|
|
"global tcl_platform\n"
|
4291 |
|
|
"if {[string equal [$w cget -state] \"disabled\"] || \\\n"
|
4292 |
|
|
"\011 [string equal $w $tkPriv(postedMb)]} {\n"
|
4293 |
|
|
"return\n"
|
4294 |
|
|
"}\n"
|
4295 |
|
|
"set menu [$w cget -menu]\n"
|
4296 |
|
|
"if {[string equal $menu \"\"]} {\n"
|
4297 |
|
|
"return\n"
|
4298 |
|
|
"}\n"
|
4299 |
|
|
"set tearoff [expr {[string equal $tcl_platform(platform) \"unix\"] \\\n"
|
4300 |
|
|
"\011 || [string equal [$menu cget -type] \"tearoff\"]}]\n"
|
4301 |
|
|
"if {[string first $w $menu] != 0} {\n"
|
4302 |
|
|
"error \"can't post $menu: it isn't a descendant of $w (this is a new requirement in Tk versions 3.0 and later)\"\n"
|
4303 |
|
|
"}\n"
|
4304 |
|
|
"set cur $tkPriv(postedMb)\n"
|
4305 |
|
|
"if {[string compare $cur \"\"]} {\n"
|
4306 |
|
|
"tkMenuUnpost {}\n"
|
4307 |
|
|
"}\n"
|
4308 |
|
|
"set tkPriv(cursor) [$w cget -cursor]\n"
|
4309 |
|
|
"set tkPriv(relief) [$w cget -relief]\n"
|
4310 |
|
|
"$w configure -cursor arrow\n"
|
4311 |
|
|
"$w configure -relief raised\n"
|
4312 |
|
|
"set tkPriv(postedMb) $w\n"
|
4313 |
|
|
"set tkPriv(focus) [focus]\n"
|
4314 |
|
|
"$menu activate none\n"
|
4315 |
|
|
"tkGenerateMenuSelect $menu\n"
|
4316 |
|
|
"update idletasks\n"
|
4317 |
|
|
"if {[catch {\n"
|
4318 |
|
|
"switch [$w cget -direction] {\n"
|
4319 |
|
|
"above {\n"
|
4320 |
|
|
"set x [winfo rootx $w]\n"
|
4321 |
|
|
"set y [expr {[winfo rooty $w] - [winfo reqheight $menu]}]\n"
|
4322 |
|
|
"$menu post $x $y\n"
|
4323 |
|
|
"}\n"
|
4324 |
|
|
"below {\n"
|
4325 |
|
|
"set x [winfo rootx $w]\n"
|
4326 |
|
|
"set y [expr {[winfo rooty $w] + [winfo height $w]}]\n"
|
4327 |
|
|
"$menu post $x $y\n"
|
4328 |
|
|
"}\n"
|
4329 |
|
|
"left {\n"
|
4330 |
|
|
"set x [expr {[winfo rootx $w] - [winfo reqwidth $menu]}]\n"
|
4331 |
|
|
"set y [expr {(2 * [winfo rooty $w] + [winfo height $w]) / 2}]\n"
|
4332 |
|
|
"set entry [tkMenuFindName $menu [$w cget -text]]\n"
|
4333 |
|
|
"if {[$w cget -indicatoron]} {\n"
|
4334 |
|
|
"if {$entry == [$menu index last]} {\n"
|
4335 |
|
|
"incr y [expr {-([$menu yposition $entry] \\\n"
|
4336 |
|
|
"\011\011\011 \011+ [winfo reqheight $menu])/2}]\n"
|
4337 |
|
|
"} else {\n"
|
4338 |
|
|
"incr y [expr {-([$menu yposition $entry] \\\n"
|
4339 |
|
|
"\011\011\011 + [$menu yposition [expr {$entry+1}]])/2}]\n"
|
4340 |
|
|
"}\n"
|
4341 |
|
|
"}\n"
|
4342 |
|
|
"$menu post $x $y\n"
|
4343 |
|
|
"if {[string compare $entry {}] && [string compare [$menu entrycget $entry -state] \"disabled\"]} {\n"
|
4344 |
|
|
"$menu activate $entry\n"
|
4345 |
|
|
"tkGenerateMenuSelect $menu\n"
|
4346 |
|
|
"}\n"
|
4347 |
|
|
"}\n"
|
4348 |
|
|
"right {\n"
|
4349 |
|
|
"set x [expr {[winfo rootx $w] + [winfo width $w]}]\n"
|
4350 |
|
|
"set y [expr {(2 * [winfo rooty $w] + [winfo height $w]) / 2}]\n"
|
4351 |
|
|
"set entry [tkMenuFindName $menu [$w cget -text]]\n"
|
4352 |
|
|
"if {[$w cget -indicatoron]} {\n"
|
4353 |
|
|
"if {$entry == [$menu index last]} {\n"
|
4354 |
|
|
"incr y [expr {-([$menu yposition $entry] \\\n"
|
4355 |
|
|
"\011\011\011 \011+ [winfo reqheight $menu])/2}]\n"
|
4356 |
|
|
"} else {\n"
|
4357 |
|
|
"incr y [expr {-([$menu yposition $entry] \\\n"
|
4358 |
|
|
"\011\011\011 + [$menu yposition [expr {$entry+1}]])/2}]\n"
|
4359 |
|
|
"}\n"
|
4360 |
|
|
"}\n"
|
4361 |
|
|
"$menu post $x $y\n"
|
4362 |
|
|
"if {[string compare $entry {}] && [string compare [$menu entrycget $entry -state] \"disabled\"]} {\n"
|
4363 |
|
|
"$menu activate $entry\n"
|
4364 |
|
|
"tkGenerateMenuSelect $menu\n"
|
4365 |
|
|
"}\n"
|
4366 |
|
|
"}\n"
|
4367 |
|
|
"default {\n"
|
4368 |
|
|
"if {[$w cget -indicatoron]} {\n"
|
4369 |
|
|
"if {[string equal $y {}]} {\n"
|
4370 |
|
|
"set x [expr {[winfo rootx $w] + [winfo width $w]/2}]\n"
|
4371 |
|
|
"set y [expr {[winfo rooty $w] + [winfo height $w]/2}]\n"
|
4372 |
|
|
"}\n"
|
4373 |
|
|
"tkPostOverPoint $menu $x $y [tkMenuFindName $menu [$w cget -text]]\n"
|
4374 |
|
|
"} else {\n"
|
4375 |
|
|
"$menu post [winfo rootx $w] [expr {[winfo rooty $w]+[winfo height $w]}]\n"
|
4376 |
|
|
"} \n"
|
4377 |
|
|
"}\n"
|
4378 |
|
|
"}\n"
|
4379 |
|
|
"} msg]} {\n"
|
4380 |
|
|
"set savedInfo $errorInfo\n"
|
4381 |
|
|
"tkMenuUnpost {}\n"
|
4382 |
|
|
"error $msg $savedInfo\n"
|
4383 |
|
|
"}\n"
|
4384 |
|
|
"set tkPriv(tearoff) $tearoff\n"
|
4385 |
|
|
"if {$tearoff != 0} {\n"
|
4386 |
|
|
"focus $menu\n"
|
4387 |
|
|
"if {[winfo viewable $w]} {\n"
|
4388 |
|
|
"tkSaveGrabInfo $w\n"
|
4389 |
|
|
"grab -global $w\n"
|
4390 |
|
|
"}\n"
|
4391 |
|
|
"}\n"
|
4392 |
|
|
"}\n"
|
4393 |
|
|
"proc tkMenuUnpost menu {\n"
|
4394 |
|
|
"global tcl_platform\n"
|
4395 |
|
|
"global tkPriv\n"
|
4396 |
|
|
"set mb $tkPriv(postedMb)\n"
|
4397 |
|
|
"catch {focus $tkPriv(focus)}\n"
|
4398 |
|
|
"set tkPriv(focus) \"\"\n"
|
4399 |
|
|
"catch {\n"
|
4400 |
|
|
"if {[string compare $mb \"\"]} {\n"
|
4401 |
|
|
"set menu [$mb cget -menu]\n"
|
4402 |
|
|
"$menu unpost\n"
|
4403 |
|
|
"set tkPriv(postedMb) {}\n"
|
4404 |
|
|
"$mb configure -cursor $tkPriv(cursor)\n"
|
4405 |
|
|
"$mb configure -relief $tkPriv(relief)\n"
|
4406 |
|
|
"} elseif {[string compare $tkPriv(popup) \"\"]} {\n"
|
4407 |
|
|
"$tkPriv(popup) unpost\n"
|
4408 |
|
|
"set tkPriv(popup) {}\n"
|
4409 |
|
|
"} elseif {[string compare [$menu cget -type] \"menubar\"] \\\n"
|
4410 |
|
|
"\011\011&& [string compare [$menu cget -type] \"tearoff\"]} {\n"
|
4411 |
|
|
"while {1} {\n"
|
4412 |
|
|
"set parent [winfo parent $menu]\n"
|
4413 |
|
|
"if {[string compare [winfo class $parent] \"Menu\"] \\\n"
|
4414 |
|
|
"\011\011\011|| ![winfo ismapped $parent]} {\n"
|
4415 |
|
|
"break\n"
|
4416 |
|
|
"}\n"
|
4417 |
|
|
"$parent activate none\n"
|
4418 |
|
|
"$parent postcascade none\n"
|
4419 |
|
|
"tkGenerateMenuSelect $parent\n"
|
4420 |
|
|
"set type [$parent cget -type]\n"
|
4421 |
|
|
"if {[string equal $type \"menubar\"] || \\\n"
|
4422 |
|
|
"\011\011\011[string equal $type \"tearoff\"]} {\n"
|
4423 |
|
|
"break\n"
|
4424 |
|
|
"}\n"
|
4425 |
|
|
"set menu $parent\n"
|
4426 |
|
|
"}\n"
|
4427 |
|
|
"if {[string compare [$menu cget -type] \"menubar\"]} {\n"
|
4428 |
|
|
"$menu unpost\n"
|
4429 |
|
|
"}\n"
|
4430 |
|
|
"}\n"
|
4431 |
|
|
"}\n"
|
4432 |
|
|
"if {($tkPriv(tearoff) != 0) || [string compare $tkPriv(menuBar) \"\"]} {\n"
|
4433 |
|
|
"if {[string compare $menu \"\"]} {\n"
|
4434 |
|
|
"set grab [grab current $menu]\n"
|
4435 |
|
|
"if {[string compare $grab \"\"]} {\n"
|
4436 |
|
|
"grab release $grab\n"
|
4437 |
|
|
"}\n"
|
4438 |
|
|
"}\n"
|
4439 |
|
|
"tkRestoreOldGrab\n"
|
4440 |
|
|
"if {[string compare $tkPriv(menuBar) \"\"]} {\n"
|
4441 |
|
|
"$tkPriv(menuBar) configure -cursor $tkPriv(cursor)\n"
|
4442 |
|
|
"set tkPriv(menuBar) {}\n"
|
4443 |
|
|
"}\n"
|
4444 |
|
|
"if {[string compare $tcl_platform(platform) \"unix\"]} {\n"
|
4445 |
|
|
"set tkPriv(tearoff) 0\n"
|
4446 |
|
|
"}\n"
|
4447 |
|
|
"}\n"
|
4448 |
|
|
"}\n"
|
4449 |
|
|
"proc tkMbMotion {w upDown rootx rooty} {\n"
|
4450 |
|
|
"global tkPriv\n"
|
4451 |
|
|
"if {[string equal $tkPriv(inMenubutton) $w]} {\n"
|
4452 |
|
|
"return\n"
|
4453 |
|
|
"}\n"
|
4454 |
|
|
"set new [winfo containing $rootx $rooty]\n"
|
4455 |
|
|
"if {[string compare $new $tkPriv(inMenubutton)] \\\n"
|
4456 |
|
|
"\011 && ([string equal $new \"\"] \\\n"
|
4457 |
|
|
"\011 || [string equal [winfo toplevel $new] [winfo toplevel $w]])} {\n"
|
4458 |
|
|
"if {[string compare $tkPriv(inMenubutton) \"\"]} {\n"
|
4459 |
|
|
"tkMbLeave $tkPriv(inMenubutton)\n"
|
4460 |
|
|
"}\n"
|
4461 |
|
|
"if {[string compare $new \"\"] \\\n"
|
4462 |
|
|
"\011\011&& [string equal [winfo class $new] \"Menubutton\"] \\\n"
|
4463 |
|
|
"\011\011&& ([$new cget -indicatoron] == 0) \\\n"
|
4464 |
|
|
"\011\011&& ([$w cget -indicatoron] == 0)} {\n"
|
4465 |
|
|
"if {[string equal $upDown \"down\"]} {\n"
|
4466 |
|
|
"tkMbPost $new $rootx $rooty\n"
|
4467 |
|
|
"} else {\n"
|
4468 |
|
|
"tkMbEnter $new\n"
|
4469 |
|
|
"}\n"
|
4470 |
|
|
"}\n"
|
4471 |
|
|
"}\n"
|
4472 |
|
|
"}\n"
|
4473 |
|
|
"proc tkMbButtonUp w {\n"
|
4474 |
|
|
"global tkPriv\n"
|
4475 |
|
|
"global tcl_platform\n"
|
4476 |
|
|
"set menu [$w cget -menu]\n"
|
4477 |
|
|
"set tearoff [expr {[string equal $tcl_platform(platform) \"unix\"] || \\\n"
|
4478 |
|
|
"\011 ([string compare $menu {}] && \\\n"
|
4479 |
|
|
"\011 [string equal [$menu cget -type] \"tearoff\"])}]\n"
|
4480 |
|
|
"if {($tearoff != 0) && [string equal $tkPriv(postedMb) $w] \\\n"
|
4481 |
|
|
"\011 && [string equal $tkPriv(inMenubutton) $w]} {\n"
|
4482 |
|
|
"tkMenuFirstEntry [$tkPriv(postedMb) cget -menu]\n"
|
4483 |
|
|
"} else {\n"
|
4484 |
|
|
"tkMenuUnpost {}\n"
|
4485 |
|
|
"}\n"
|
4486 |
|
|
"}\n"
|
4487 |
|
|
"proc tkMenuMotion {menu x y state} {\n"
|
4488 |
|
|
"global tkPriv\n"
|
4489 |
|
|
"if {[string equal $menu $tkPriv(window)]} {\n"
|
4490 |
|
|
"if {[string equal [$menu cget -type] \"menubar\"]} {\n"
|
4491 |
|
|
"if {[info exists tkPriv(focus)] && \\\n"
|
4492 |
|
|
"\011\011 [string compare $menu $tkPriv(focus)]} {\n"
|
4493 |
|
|
"$menu activate @$x,$y\n"
|
4494 |
|
|
"tkGenerateMenuSelect $menu\n"
|
4495 |
|
|
"}\n"
|
4496 |
|
|
"} else {\n"
|
4497 |
|
|
"$menu activate @$x,$y\n"
|
4498 |
|
|
"tkGenerateMenuSelect $menu\n"
|
4499 |
|
|
"}\n"
|
4500 |
|
|
"}\n"
|
4501 |
|
|
"if {($state & 0x1f00) != 0} {\n"
|
4502 |
|
|
"$menu postcascade active\n"
|
4503 |
|
|
"}\n"
|
4504 |
|
|
"}\n"
|
4505 |
|
|
"proc tkMenuButtonDown menu {\n"
|
4506 |
|
|
"global tkPriv\n"
|
4507 |
|
|
"global tcl_platform\n"
|
4508 |
|
|
"if {![winfo viewable $menu]} {\n"
|
4509 |
|
|
"return\n"
|
4510 |
|
|
"}\n"
|
4511 |
|
|
"$menu postcascade active\n"
|
4512 |
|
|
"if {[string compare $tkPriv(postedMb) \"\"] && \\\n"
|
4513 |
|
|
"\011 [winfo viewable $tkPriv(postedMb)]} {\n"
|
4514 |
|
|
"grab -global $tkPriv(postedMb)\n"
|
4515 |
|
|
"} else {\n"
|
4516 |
|
|
"while {[string equal [$menu cget -type] \"normal\"] \\\n"
|
4517 |
|
|
"\011\011&& [string equal [winfo class [winfo parent $menu]] \"Menu\"] \\\n"
|
4518 |
|
|
"\011\011&& [winfo ismapped [winfo parent $menu]]} {\n"
|
4519 |
|
|
"set menu [winfo parent $menu]\n"
|
4520 |
|
|
"}\n"
|
4521 |
|
|
"if {[string equal $tkPriv(menuBar) {}]} {\n"
|
4522 |
|
|
"set tkPriv(menuBar) $menu\n"
|
4523 |
|
|
"set tkPriv(cursor) [$menu cget -cursor]\n"
|
4524 |
|
|
"$menu configure -cursor arrow\n"
|
4525 |
|
|
"}\n"
|
4526 |
|
|
"if {[string compare $menu [grab current $menu]]} {\n"
|
4527 |
|
|
"tkSaveGrabInfo $menu\n"
|
4528 |
|
|
"}\n"
|
4529 |
|
|
"if {[string equal $tcl_platform(platform) \"unix\"]} {\n"
|
4530 |
|
|
"grab -global $menu\n"
|
4531 |
|
|
"}\n"
|
4532 |
|
|
"}\n"
|
4533 |
|
|
"}\n"
|
4534 |
|
|
"proc tkMenuLeave {menu rootx rooty state} {\n"
|
4535 |
|
|
"global tkPriv\n"
|
4536 |
|
|
"set tkPriv(window) {}\n"
|
4537 |
|
|
"if {[string equal [$menu index active] \"none\"]} {\n"
|
4538 |
|
|
"return\n"
|
4539 |
|
|
"}\n"
|
4540 |
|
|
"if {[string equal [$menu type active] \"cascade\"]\n"
|
4541 |
|
|
"&& [string equal [winfo containing $rootx $rooty] \\\n"
|
4542 |
|
|
" [$menu entrycget active -menu]]} {\n"
|
4543 |
|
|
"return\n"
|
4544 |
|
|
"}\n"
|
4545 |
|
|
"$menu activate none\n"
|
4546 |
|
|
"tkGenerateMenuSelect $menu\n"
|
4547 |
|
|
"}\n"
|
4548 |
|
|
"proc tkMenuInvoke {w buttonRelease} {\n"
|
4549 |
|
|
"global tkPriv\n"
|
4550 |
|
|
"if {$buttonRelease && [string equal $tkPriv(window) {}]} {\n"
|
4551 |
|
|
"$w postcascade none\n"
|
4552 |
|
|
"$w activate none\n"
|
4553 |
|
|
"event generate $w <<MenuSelect>>\n"
|
4554 |
|
|
"tkMenuUnpost $w\n"
|
4555 |
|
|
"return\n"
|
4556 |
|
|
"}\n"
|
4557 |
|
|
"if {[string equal [$w type active] \"cascade\"]} {\n"
|
4558 |
|
|
"$w postcascade active\n"
|
4559 |
|
|
"set menu [$w entrycget active -menu]\n"
|
4560 |
|
|
"tkMenuFirstEntry $menu\n"
|
4561 |
|
|
"} elseif {[string equal [$w type active] \"tearoff\"]} {\n"
|
4562 |
|
|
"tkTearOffMenu $w\n"
|
4563 |
|
|
"tkMenuUnpost $w\n"
|
4564 |
|
|
"} elseif {[string equal [$w cget -type] \"menubar\"]} {\n"
|
4565 |
|
|
"$w postcascade none\n"
|
4566 |
|
|
"set active [$w index active]\n"
|
4567 |
|
|
"set isCascade [string equal [$w type $active] \"cascade\"]\n"
|
4568 |
|
|
"if { $isCascade } {\n"
|
4569 |
|
|
"$w activate none\n"
|
4570 |
|
|
"event generate $w <<MenuSelect>>\n"
|
4571 |
|
|
"}\n"
|
4572 |
|
|
"tkMenuUnpost $w\n"
|
4573 |
|
|
"if { !$isCascade } {\n"
|
4574 |
|
|
"uplevel #0 [list $w invoke $active]\n"
|
4575 |
|
|
"}\n"
|
4576 |
|
|
"} else {\n"
|
4577 |
|
|
"tkMenuUnpost $w\n"
|
4578 |
|
|
"uplevel #0 [list $w invoke active]\n"
|
4579 |
|
|
"}\n"
|
4580 |
|
|
"}\n"
|
4581 |
|
|
"proc tkMenuEscape menu {\n"
|
4582 |
|
|
"set parent [winfo parent $menu]\n"
|
4583 |
|
|
"if {[string compare [winfo class $parent] \"Menu\"]} {\n"
|
4584 |
|
|
"tkMenuUnpost $menu\n"
|
4585 |
|
|
"} elseif {[string equal [$parent cget -type] \"menubar\"]} {\n"
|
4586 |
|
|
"tkMenuUnpost $menu\n"
|
4587 |
|
|
"tkRestoreOldGrab\n"
|
4588 |
|
|
"} else {\n"
|
4589 |
|
|
"tkMenuNextMenu $menu left\n"
|
4590 |
|
|
"}\n"
|
4591 |
|
|
"}\n"
|
4592 |
|
|
"proc tkMenuUpArrow {menu} {\n"
|
4593 |
|
|
"if {[string equal [$menu cget -type] \"menubar\"]} {\n"
|
4594 |
|
|
"tkMenuNextMenu $menu left\n"
|
4595 |
|
|
"} else {\n"
|
4596 |
|
|
"tkMenuNextEntry $menu -1\n"
|
4597 |
|
|
"}\n"
|
4598 |
|
|
"}\n"
|
4599 |
|
|
"proc tkMenuDownArrow {menu} {\n"
|
4600 |
|
|
"if {[string equal [$menu cget -type] \"menubar\"]} {\n"
|
4601 |
|
|
"tkMenuNextMenu $menu right\n"
|
4602 |
|
|
"} else {\n"
|
4603 |
|
|
"tkMenuNextEntry $menu 1\n"
|
4604 |
|
|
"}\n"
|
4605 |
|
|
"}\n"
|
4606 |
|
|
"proc tkMenuLeftArrow {menu} {\n"
|
4607 |
|
|
"if {[string equal [$menu cget -type] \"menubar\"]} {\n"
|
4608 |
|
|
"tkMenuNextEntry $menu -1\n"
|
4609 |
|
|
"} else {\n"
|
4610 |
|
|
"tkMenuNextMenu $menu left\n"
|
4611 |
|
|
"}\n"
|
4612 |
|
|
"}\n"
|
4613 |
|
|
"proc tkMenuRightArrow {menu} {\n"
|
4614 |
|
|
"if {[string equal [$menu cget -type] \"menubar\"]} {\n"
|
4615 |
|
|
"tkMenuNextEntry $menu 1\n"
|
4616 |
|
|
"} else {\n"
|
4617 |
|
|
"tkMenuNextMenu $menu right\n"
|
4618 |
|
|
"}\n"
|
4619 |
|
|
"}\n"
|
4620 |
|
|
"proc tkMenuNextMenu {menu direction} {\n"
|
4621 |
|
|
"global tkPriv\n"
|
4622 |
|
|
"if {[string equal $direction \"right\"]} {\n"
|
4623 |
|
|
"set count 1\n"
|
4624 |
|
|
"set parent [winfo parent $menu]\n"
|
4625 |
|
|
"set class [winfo class $parent]\n"
|
4626 |
|
|
"if {[string equal [$menu type active] \"cascade\"]} {\n"
|
4627 |
|
|
"$menu postcascade active\n"
|
4628 |
|
|
"set m2 [$menu entrycget active -menu]\n"
|
4629 |
|
|
"if {[string compare $m2 \"\"]} {\n"
|
4630 |
|
|
"tkMenuFirstEntry $m2\n"
|
4631 |
|
|
"}\n"
|
4632 |
|
|
"return\n"
|
4633 |
|
|
"} else {\n"
|
4634 |
|
|
"set parent [winfo parent $menu]\n"
|
4635 |
|
|
"while {[string compare $parent \".\"]} {\n"
|
4636 |
|
|
"if {[string equal [winfo class $parent] \"Menu\"] \\\n"
|
4637 |
|
|
"\011\011\011&& [string equal [$parent cget -type] \"menubar\"]} {\n"
|
4638 |
|
|
"tk_menuSetFocus $parent\n"
|
4639 |
|
|
"tkMenuNextEntry $parent 1\n"
|
4640 |
|
|
"return\n"
|
4641 |
|
|
"}\n"
|
4642 |
|
|
"set parent [winfo parent $parent]\n"
|
4643 |
|
|
"}\n"
|
4644 |
|
|
"}\n"
|
4645 |
|
|
"} else {\n"
|
4646 |
|
|
"set count -1\n"
|
4647 |
|
|
"set m2 [winfo parent $menu]\n"
|
4648 |
|
|
"if {[string equal [winfo class $m2] \"Menu\"]} {\n"
|
4649 |
|
|
"if {[string compare [$m2 cget -type] \"menubar\"]} {\n"
|
4650 |
|
|
"$menu activate none\n"
|
4651 |
|
|
"tkGenerateMenuSelect $menu\n"
|
4652 |
|
|
"tk_menuSetFocus $m2\n"
|
4653 |
|
|
"set tmp [$m2 index active]\n"
|
4654 |
|
|
"$m2 activate none\n"
|
4655 |
|
|
"$m2 activate $tmp\n"
|
4656 |
|
|
"return\n"
|
4657 |
|
|
"}\n"
|
4658 |
|
|
"}\n"
|
4659 |
|
|
"}\n"
|
4660 |
|
|
"set m2 [winfo parent $menu]\n"
|
4661 |
|
|
"if {[string equal [winfo class $m2] \"Menu\"]} {\n"
|
4662 |
|
|
"if {[string equal [$m2 cget -type] \"menubar\"]} {\n"
|
4663 |
|
|
"tk_menuSetFocus $m2\n"
|
4664 |
|
|
"tkMenuNextEntry $m2 -1\n"
|
4665 |
|
|
"return\n"
|
4666 |
|
|
"}\n"
|
4667 |
|
|
"}\n"
|
4668 |
|
|
"set w $tkPriv(postedMb)\n"
|
4669 |
|
|
"if {[string equal $w \"\"]} {\n"
|
4670 |
|
|
"return\n"
|
4671 |
|
|
"}\n"
|
4672 |
|
|
"set buttons [winfo children [winfo parent $w]]\n"
|
4673 |
|
|
"set length [llength $buttons]\n"
|
4674 |
|
|
"set i [expr {[lsearch -exact $buttons $w] + $count}]\n"
|
4675 |
|
|
"while {1} {\n"
|
4676 |
|
|
"while {$i < 0} {\n"
|
4677 |
|
|
"incr i $length\n"
|
4678 |
|
|
"}\n"
|
4679 |
|
|
"while {$i >= $length} {\n"
|
4680 |
|
|
"incr i -$length\n"
|
4681 |
|
|
"}\n"
|
4682 |
|
|
"set mb [lindex $buttons $i]\n"
|
4683 |
|
|
"if {[string equal [winfo class $mb] \"Menubutton\"] \\\n"
|
4684 |
|
|
"\011\011&& [string compare [$mb cget -state] \"disabled\"] \\\n"
|
4685 |
|
|
"\011\011&& [string compare [$mb cget -menu] \"\"] \\\n"
|
4686 |
|
|
"\011\011&& [string compare [[$mb cget -menu] index last] \"none\"]} {\n"
|
4687 |
|
|
"break\n"
|
4688 |
|
|
"}\n"
|
4689 |
|
|
"if {[string equal $mb $w]} {\n"
|
4690 |
|
|
"return\n"
|
4691 |
|
|
"}\n"
|
4692 |
|
|
"incr i $count\n"
|
4693 |
|
|
"}\n"
|
4694 |
|
|
"tkMbPost $mb\n"
|
4695 |
|
|
"tkMenuFirstEntry [$mb cget -menu]\n"
|
4696 |
|
|
"}\n"
|
4697 |
|
|
"proc tkMenuNextEntry {menu count} {\n"
|
4698 |
|
|
"global tkPriv\n"
|
4699 |
|
|
"if {[string equal [$menu index last] \"none\"]} {\n"
|
4700 |
|
|
"return\n"
|
4701 |
|
|
"}\n"
|
4702 |
|
|
"set length [expr {[$menu index last]+1}]\n"
|
4703 |
|
|
"set quitAfter $length\n"
|
4704 |
|
|
"set active [$menu index active]\n"
|
4705 |
|
|
"if {[string equal $active \"none\"]} {\n"
|
4706 |
|
|
"set i 0\n"
|
4707 |
|
|
"} else {\n"
|
4708 |
|
|
"set i [expr {$active + $count}]\n"
|
4709 |
|
|
"}\n"
|
4710 |
|
|
"while {1} {\n"
|
4711 |
|
|
"if {$quitAfter <= 0} {\n"
|
4712 |
|
|
"return\n"
|
4713 |
|
|
"}\n"
|
4714 |
|
|
"while {$i < 0} {\n"
|
4715 |
|
|
"incr i $length\n"
|
4716 |
|
|
"}\n"
|
4717 |
|
|
"while {$i >= $length} {\n"
|
4718 |
|
|
"incr i -$length\n"
|
4719 |
|
|
"}\n"
|
4720 |
|
|
"if {[catch {$menu entrycget $i -state} state] == 0} {\n"
|
4721 |
|
|
"if {[string compare $state \"disabled\"]} {\n"
|
4722 |
|
|
"break\n"
|
4723 |
|
|
"}\n"
|
4724 |
|
|
"}\n"
|
4725 |
|
|
"if {$i == $active} {\n"
|
4726 |
|
|
"return\n"
|
4727 |
|
|
"}\n"
|
4728 |
|
|
"incr i $count\n"
|
4729 |
|
|
"incr quitAfter -1\n"
|
4730 |
|
|
"}\n"
|
4731 |
|
|
"$menu activate $i\n"
|
4732 |
|
|
"tkGenerateMenuSelect $menu\n"
|
4733 |
|
|
"if {[string equal [$menu type $i] \"cascade\"]} {\n"
|
4734 |
|
|
"set cascade [$menu entrycget $i -menu]\n"
|
4735 |
|
|
"if {[string compare $cascade \"\"]} {\n"
|
4736 |
|
|
"$menu postcascade $i\n"
|
4737 |
|
|
"tkMenuFirstEntry $cascade\n"
|
4738 |
|
|
"}\n"
|
4739 |
|
|
"}\n"
|
4740 |
|
|
"}\n"
|
4741 |
|
|
"proc tkMenuFind {w char} {\n"
|
4742 |
|
|
"global tkPriv\n"
|
4743 |
|
|
"set char [string tolower $char]\n"
|
4744 |
|
|
"set windowlist [winfo child $w]\n"
|
4745 |
|
|
"foreach child $windowlist {\n"
|
4746 |
|
|
"if {[string compare [winfo toplevel [focus]] \\\n"
|
4747 |
|
|
"\011\011[winfo toplevel $child]]} {\n"
|
4748 |
|
|
"continue\n"
|
4749 |
|
|
"}\n"
|
4750 |
|
|
"if {[string equal [winfo class $child] \"Menu\"] && \\\n"
|
4751 |
|
|
"\011\011[string equal [$child cget -type] \"menubar\"]} {\n"
|
4752 |
|
|
"if {[string equal $char \"\"]} {\n"
|
4753 |
|
|
"return $child\n"
|
4754 |
|
|
"}\n"
|
4755 |
|
|
"set last [$child index last]\n"
|
4756 |
|
|
"for {set i [$child cget -tearoff]} {$i <= $last} {incr i} {\n"
|
4757 |
|
|
"if {[string equal [$child type $i] \"separator\"]} {\n"
|
4758 |
|
|
"continue\n"
|
4759 |
|
|
"}\n"
|
4760 |
|
|
"set char2 [string index [$child entrycget $i -label] \\\n"
|
4761 |
|
|
"\011\011\011[$child entrycget $i -underline]]\n"
|
4762 |
|
|
"if {[string equal $char [string tolower $char2]] \\\n"
|
4763 |
|
|
"\011\011\011|| [string equal $char \"\"]} {\n"
|
4764 |
|
|
"if {[string compare [$child entrycget $i -state] \"disabled\"]} {\n"
|
4765 |
|
|
"return $child\n"
|
4766 |
|
|
"}\n"
|
4767 |
|
|
"}\n"
|
4768 |
|
|
"}\n"
|
4769 |
|
|
"}\n"
|
4770 |
|
|
"}\n"
|
4771 |
|
|
"foreach child $windowlist {\n"
|
4772 |
|
|
"if {[string compare [winfo toplevel [focus]] \\\n"
|
4773 |
|
|
"\011\011[winfo toplevel $child]]} {\n"
|
4774 |
|
|
"continue\n"
|
4775 |
|
|
"}\n"
|
4776 |
|
|
"switch [winfo class $child] {\n"
|
4777 |
|
|
"Menubutton {\n"
|
4778 |
|
|
"set char2 [string index [$child cget -text] \\\n"
|
4779 |
|
|
"\011\011\011[$child cget -underline]]\n"
|
4780 |
|
|
"if {[string equal $char [string tolower $char2]] \\\n"
|
4781 |
|
|
"\011\011\011|| [string equal $char \"\"]} {\n"
|
4782 |
|
|
"if {[string compare [$child cget -state] \"disabled\"]} {\n"
|
4783 |
|
|
"return $child\n"
|
4784 |
|
|
"}\n"
|
4785 |
|
|
"}\n"
|
4786 |
|
|
"}\n"
|
4787 |
|
|
"default {\n"
|
4788 |
|
|
"set match [tkMenuFind $child $char]\n"
|
4789 |
|
|
"if {[string compare $match \"\"]} {\n"
|
4790 |
|
|
"return $match\n"
|
4791 |
|
|
"}\n"
|
4792 |
|
|
"}\n"
|
4793 |
|
|
"}\n"
|
4794 |
|
|
"}\n"
|
4795 |
|
|
"return {}\n"
|
4796 |
|
|
"}\n"
|
4797 |
|
|
"proc tkTraverseToMenu {w char} {\n"
|
4798 |
|
|
"global tkPriv\n"
|
4799 |
|
|
"if {[string equal $char \"\"]} {\n"
|
4800 |
|
|
"return\n"
|
4801 |
|
|
"}\n"
|
4802 |
|
|
"while {[string equal [winfo class $w] \"Menu\"]} {\n"
|
4803 |
|
|
"if {[string compare [$w cget -type] \"menubar\"] \\\n"
|
4804 |
|
|
"\011\011&& [string equal $tkPriv(postedMb) \"\"]} {\n"
|
4805 |
|
|
"return\n"
|
4806 |
|
|
"}\n"
|
4807 |
|
|
"if {[string equal [$w cget -type] \"menubar\"]} {\n"
|
4808 |
|
|
"break\n"
|
4809 |
|
|
"}\n"
|
4810 |
|
|
"set w [winfo parent $w]\n"
|
4811 |
|
|
"}\n"
|
4812 |
|
|
"set w [tkMenuFind [winfo toplevel $w] $char]\n"
|
4813 |
|
|
"if {[string compare $w \"\"]} {\n"
|
4814 |
|
|
"if {[string equal [winfo class $w] \"Menu\"]} {\n"
|
4815 |
|
|
"tk_menuSetFocus $w\n"
|
4816 |
|
|
"set tkPriv(window) $w\n"
|
4817 |
|
|
"tkSaveGrabInfo $w\n"
|
4818 |
|
|
"grab -global $w\n"
|
4819 |
|
|
"tkTraverseWithinMenu $w $char\n"
|
4820 |
|
|
"} else {\n"
|
4821 |
|
|
"tkMbPost $w\n"
|
4822 |
|
|
"tkMenuFirstEntry [$w cget -menu]\n"
|
4823 |
|
|
"}\n"
|
4824 |
|
|
"}\n"
|
4825 |
|
|
"}\n"
|
4826 |
|
|
"proc tkFirstMenu w {\n"
|
4827 |
|
|
"set w [tkMenuFind [winfo toplevel $w] \"\"]\n"
|
4828 |
|
|
"if {[string compare $w \"\"]} {\n"
|
4829 |
|
|
"if {[string equal [winfo class $w] \"Menu\"]} {\n"
|
4830 |
|
|
"tk_menuSetFocus $w\n"
|
4831 |
|
|
"set tkPriv(window) $w\n"
|
4832 |
|
|
"tkSaveGrabInfo $w\n"
|
4833 |
|
|
"grab -global $w\n"
|
4834 |
|
|
"tkMenuFirstEntry $w\n"
|
4835 |
|
|
"} else {\n"
|
4836 |
|
|
"tkMbPost $w\n"
|
4837 |
|
|
"tkMenuFirstEntry [$w cget -menu]\n"
|
4838 |
|
|
"}\n"
|
4839 |
|
|
"}\n"
|
4840 |
|
|
"}\n"
|
4841 |
|
|
"proc tkTraverseWithinMenu {w char} {\n"
|
4842 |
|
|
"if {[string equal $char \"\"]} {\n"
|
4843 |
|
|
"return\n"
|
4844 |
|
|
"}\n"
|
4845 |
|
|
"set char [string tolower $char]\n"
|
4846 |
|
|
"set last [$w index last]\n"
|
4847 |
|
|
"if {[string equal $last \"none\"]} {\n"
|
4848 |
|
|
"return\n"
|
4849 |
|
|
"}\n"
|
4850 |
|
|
"for {set i 0} {$i <= $last} {incr i} {\n"
|
4851 |
|
|
"if {[catch {set char2 [string index \\\n"
|
4852 |
|
|
"\011\011[$w entrycget $i -label] [$w entrycget $i -underline]]}]} {\n"
|
4853 |
|
|
"continue\n"
|
4854 |
|
|
"}\n"
|
4855 |
|
|
"if {[string equal $char [string tolower $char2]]} {\n"
|
4856 |
|
|
"if {[string equal [$w type $i] \"cascade\"]} {\n"
|
4857 |
|
|
"$w activate $i\n"
|
4858 |
|
|
"$w postcascade active\n"
|
4859 |
|
|
"event generate $w <<MenuSelect>>\n"
|
4860 |
|
|
"set m2 [$w entrycget $i -menu]\n"
|
4861 |
|
|
"if {[string compare $m2 \"\"]} {\n"
|
4862 |
|
|
"tkMenuFirstEntry $m2\n"
|
4863 |
|
|
"}\n"
|
4864 |
|
|
"} else {\n"
|
4865 |
|
|
"tkMenuUnpost $w\n"
|
4866 |
|
|
"uplevel #0 [list $w invoke $i]\n"
|
4867 |
|
|
"}\n"
|
4868 |
|
|
"return\n"
|
4869 |
|
|
"}\n"
|
4870 |
|
|
"}\n"
|
4871 |
|
|
"}\n"
|
4872 |
|
|
"proc tkMenuFirstEntry menu {\n"
|
4873 |
|
|
"if {[string equal $menu \"\"]} {\n"
|
4874 |
|
|
"return\n"
|
4875 |
|
|
"}\n"
|
4876 |
|
|
"tk_menuSetFocus $menu\n"
|
4877 |
|
|
"if {[string compare [$menu index active] \"none\"]} {\n"
|
4878 |
|
|
"return\n"
|
4879 |
|
|
"}\n"
|
4880 |
|
|
"set last [$menu index last]\n"
|
4881 |
|
|
"if {[string equal $last \"none\"]} {\n"
|
4882 |
|
|
"return\n"
|
4883 |
|
|
"}\n"
|
4884 |
|
|
"for {set i 0} {$i <= $last} {incr i} {\n"
|
4885 |
|
|
"if {([catch {set state [$menu entrycget $i -state]}] == 0) \\\n"
|
4886 |
|
|
"\011\011&& [string compare $state \"disabled\"] \\\n"
|
4887 |
|
|
"\011\011&& [string compare [$menu type $i] \"tearoff\"]} {\n"
|
4888 |
|
|
"$menu activate $i\n"
|
4889 |
|
|
"tkGenerateMenuSelect $menu\n"
|
4890 |
|
|
"if {[string equal [$menu type $i] \"cascade\"] && \\\n"
|
4891 |
|
|
"\011\011[string equal [$menu cget -type] \"menubar\"]} {\n"
|
4892 |
|
|
"set cascade [$menu entrycget $i -menu]\n"
|
4893 |
|
|
"if {[string compare $cascade \"\"]} {\n"
|
4894 |
|
|
"$menu postcascade $i\n"
|
4895 |
|
|
"tkMenuFirstEntry $cascade\n"
|
4896 |
|
|
"}\n"
|
4897 |
|
|
"}\n"
|
4898 |
|
|
"return\n"
|
4899 |
|
|
"}\n"
|
4900 |
|
|
"}\n"
|
4901 |
|
|
"}\n"
|
4902 |
|
|
"proc tkMenuFindName {menu s} {\n"
|
4903 |
|
|
"set i \"\"\n"
|
4904 |
|
|
"if {![regexp {^active$|^last$|^none$|^[0-9]|^@} $s]} {\n"
|
4905 |
|
|
"catch {set i [$menu index $s]}\n"
|
4906 |
|
|
"return $i\n"
|
4907 |
|
|
"}\n"
|
4908 |
|
|
"set last [$menu index last]\n"
|
4909 |
|
|
"if {[string equal $last \"none\"]} {\n"
|
4910 |
|
|
"return\n"
|
4911 |
|
|
"}\n"
|
4912 |
|
|
"for {set i 0} {$i <= $last} {incr i} {\n"
|
4913 |
|
|
"if {![catch {$menu entrycget $i -label} label]} {\n"
|
4914 |
|
|
"if {[string equal $label $s]} {\n"
|
4915 |
|
|
"return $i\n"
|
4916 |
|
|
"}\n"
|
4917 |
|
|
"}\n"
|
4918 |
|
|
"}\n"
|
4919 |
|
|
"return \"\"\n"
|
4920 |
|
|
"}\n"
|
4921 |
|
|
"proc tkPostOverPoint {menu x y {entry {}}} {\n"
|
4922 |
|
|
"global tcl_platform\n"
|
4923 |
|
|
"if {[string compare $entry {}]} {\n"
|
4924 |
|
|
"if {$entry == [$menu index last]} {\n"
|
4925 |
|
|
"incr y [expr {-([$menu yposition $entry] \\\n"
|
4926 |
|
|
"\011\011 + [winfo reqheight $menu])/2}]\n"
|
4927 |
|
|
"} else {\n"
|
4928 |
|
|
"incr y [expr {-([$menu yposition $entry] \\\n"
|
4929 |
|
|
"\011\011 + [$menu yposition [expr {$entry+1}]])/2}]\n"
|
4930 |
|
|
"}\n"
|
4931 |
|
|
"incr x [expr {-[winfo reqwidth $menu]/2}]\n"
|
4932 |
|
|
"}\n"
|
4933 |
|
|
"$menu post $x $y\n"
|
4934 |
|
|
"if {[string compare $entry {}] \\\n"
|
4935 |
|
|
"\011 && [string compare [$menu entrycget $entry -state] \"disabled\"]} {\n"
|
4936 |
|
|
"$menu activate $entry\n"
|
4937 |
|
|
"tkGenerateMenuSelect $menu\n"
|
4938 |
|
|
"}\n"
|
4939 |
|
|
"}\n"
|
4940 |
|
|
"proc tkSaveGrabInfo w {\n"
|
4941 |
|
|
"global tkPriv\n"
|
4942 |
|
|
"set tkPriv(oldGrab) [grab current $w]\n"
|
4943 |
|
|
"if {[string compare $tkPriv(oldGrab) \"\"]} {\n"
|
4944 |
|
|
"set tkPriv(grabStatus) [grab status $tkPriv(oldGrab)]\n"
|
4945 |
|
|
"}\n"
|
4946 |
|
|
"}\n"
|
4947 |
|
|
"proc tkRestoreOldGrab {} {\n"
|
4948 |
|
|
"global tkPriv\n"
|
4949 |
|
|
"if {[string compare $tkPriv(oldGrab) \"\"]} {\n"
|
4950 |
|
|
"catch {\n"
|
4951 |
|
|
"if {[string equal $tkPriv(grabStatus) \"global\"]} {\n"
|
4952 |
|
|
"grab set -global $tkPriv(oldGrab)\n"
|
4953 |
|
|
"} else {\n"
|
4954 |
|
|
"grab set $tkPriv(oldGrab)\n"
|
4955 |
|
|
"}\n"
|
4956 |
|
|
"}\n"
|
4957 |
|
|
"set tkPriv(oldGrab) \"\"\n"
|
4958 |
|
|
"}\n"
|
4959 |
|
|
"}\n"
|
4960 |
|
|
"proc tk_menuSetFocus {menu} {\n"
|
4961 |
|
|
"global tkPriv\n"
|
4962 |
|
|
"if {![info exists tkPriv(focus)] || [string equal $tkPriv(focus) {}]} {\n"
|
4963 |
|
|
"set tkPriv(focus) [focus]\n"
|
4964 |
|
|
"}\n"
|
4965 |
|
|
"focus $menu\n"
|
4966 |
|
|
"}\n"
|
4967 |
|
|
"proc tkGenerateMenuSelect {menu} {\n"
|
4968 |
|
|
"global tkPriv\n"
|
4969 |
|
|
"if {[string equal $tkPriv(activeMenu) $menu] \\\n"
|
4970 |
|
|
" && [string equal $tkPriv(activeItem) [$menu index active]]} {\n"
|
4971 |
|
|
"return\n"
|
4972 |
|
|
"}\n"
|
4973 |
|
|
"set tkPriv(activeMenu) $menu\n"
|
4974 |
|
|
"set tkPriv(activeItem) [$menu index active]\n"
|
4975 |
|
|
"event generate $menu <<MenuSelect>>\n"
|
4976 |
|
|
"}\n"
|
4977 |
|
|
"proc tk_popup {menu x y {entry {}}} {\n"
|
4978 |
|
|
"global tkPriv\n"
|
4979 |
|
|
"global tcl_platform\n"
|
4980 |
|
|
"if {[string compare $tkPriv(popup) \"\"] \\\n"
|
4981 |
|
|
"\011 || [string compare $tkPriv(postedMb) \"\"]} {\n"
|
4982 |
|
|
"tkMenuUnpost {}\n"
|
4983 |
|
|
"}\n"
|
4984 |
|
|
"tkPostOverPoint $menu $x $y $entry\n"
|
4985 |
|
|
"if {[string equal $tcl_platform(platform) \"unix\"] \\\n"
|
4986 |
|
|
"\011 && [winfo viewable $menu]} {\n"
|
4987 |
|
|
"tkSaveGrabInfo $menu\n"
|
4988 |
|
|
"grab -global $menu\n"
|
4989 |
|
|
"set tkPriv(popup) $menu\n"
|
4990 |
|
|
"tk_menuSetFocus $menu\n"
|
4991 |
|
|
"}\n"
|
4992 |
|
|
"}\n"
|
4993 |
|
|
;
|
4994 |
|
|
static char Et_zFile18[] =
|
4995 |
|
|
"namespace eval ::tk::dialog {}\n"
|
4996 |
|
|
"image create bitmap ::tk::dialog::b1 -foreground black \\\n"
|
4997 |
|
|
"-data \"#define b1_width 32\\n#define b1_height 32\n"
|
4998 |
|
|
"static unsigned char q1_bits[] = {\n"
|
4999 |
|
|
"0x00, 0xf8, 0x1f, 0x00, 0x00, 0x07, 0xe0, 0x00, 0xc0, 0x00, 0x00, 0x03,\n"
|
5000 |
|
|
"0x20, 0x00, 0x00, 0x04, 0x10, 0x00, 0x00, 0x08, 0x08, 0x00, 0x00, 0x10,\n"
|
5001 |
|
|
"0x04, 0x00, 0x00, 0x20, 0x02, 0x00, 0x00, 0x40, 0x02, 0x00, 0x00, 0x40,\n"
|
5002 |
|
|
"0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80,\n"
|
5003 |
|
|
"0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80,\n"
|
5004 |
|
|
"0x01, 0x00, 0x00, 0x80, 0x02, 0x00, 0x00, 0x40, 0x02, 0x00, 0x00, 0x40,\n"
|
5005 |
|
|
"0x04, 0x00, 0x00, 0x20, 0x08, 0x00, 0x00, 0x10, 0x10, 0x00, 0x00, 0x08,\n"
|
5006 |
|
|
"0x60, 0x00, 0x00, 0x04, 0x80, 0x03, 0x80, 0x03, 0x00, 0x0c, 0x78, 0x00,\n"
|
5007 |
|
|
"0x00, 0x30, 0x04, 0x00, 0x00, 0x40, 0x04, 0x00, 0x00, 0x40, 0x04, 0x00,\n"
|
5008 |
|
|
"0x00, 0x80, 0x04, 0x00, 0x00, 0x00, 0x05, 0x00, 0x00, 0x00, 0x06, 0x00,\n"
|
5009 |
|
|
"0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};\"\n"
|
5010 |
|
|
"image create bitmap ::tk::dialog::b2 -foreground white \\\n"
|
5011 |
|
|
"-data \"#define b2_width 32\\n#define b2_height 32\n"
|
5012 |
|
|
"static unsigned char b2_bits[] = {\n"
|
5013 |
|
|
"0x00, 0x00, 0x00, 0x00, 0x00, 0xf8, 0x1f, 0x00, 0x00, 0xff, 0xff, 0x00,\n"
|
5014 |
|
|
"0xc0, 0xff, 0xff, 0x03, 0xe0, 0xff, 0xff, 0x07, 0xf0, 0xff, 0xff, 0x0f,\n"
|
5015 |
|
|
"0xf8, 0xff, 0xff, 0x1f, 0xfc, 0xff, 0xff, 0x3f, 0xfc, 0xff, 0xff, 0x3f,\n"
|
5016 |
|
|
"0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f,\n"
|
5017 |
|
|
"0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f,\n"
|
5018 |
|
|
"0xfe, 0xff, 0xff, 0x7f, 0xfc, 0xff, 0xff, 0x3f, 0xfc, 0xff, 0xff, 0x3f,\n"
|
5019 |
|
|
"0xf8, 0xff, 0xff, 0x1f, 0xf0, 0xff, 0xff, 0x0f, 0xe0, 0xff, 0xff, 0x07,\n"
|
5020 |
|
|
"0x80, 0xff, 0xff, 0x03, 0x00, 0xfc, 0x7f, 0x00, 0x00, 0xf0, 0x07, 0x00,\n"
|
5021 |
|
|
"0x00, 0xc0, 0x03, 0x00, 0x00, 0x80, 0x03, 0x00, 0x00, 0x80, 0x03, 0x00,\n"
|
5022 |
|
|
"0x00, 0x00, 0x03, 0x00, 0x00, 0x00, 0x02, 0x00, 0x00, 0x00, 0x00, 0x00,\n"
|
5023 |
|
|
"0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};\"\n"
|
5024 |
|
|
"image create bitmap ::tk::dialog::q -foreground blue \\\n"
|
5025 |
|
|
"-data \"#define q_width 32\\n#define q_height 32\n"
|
5026 |
|
|
"static unsigned char q_bits[] = {\n"
|
5027 |
|
|
"0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,\n"
|
5028 |
|
|
"0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xe0, 0x07, 0x00,\n"
|
5029 |
|
|
"0x00, 0x10, 0x0f, 0x00, 0x00, 0x18, 0x1e, 0x00, 0x00, 0x38, 0x1e, 0x00,\n"
|
5030 |
|
|
"0x00, 0x38, 0x1e, 0x00, 0x00, 0x10, 0x0f, 0x00, 0x00, 0x80, 0x07, 0x00,\n"
|
5031 |
|
|
"0x00, 0xc0, 0x01, 0x00, 0x00, 0xc0, 0x00, 0x00, 0x00, 0xc0, 0x00, 0x00,\n"
|
5032 |
|
|
"0x00, 0x00, 0x00, 0x00, 0x00, 0xc0, 0x00, 0x00, 0x00, 0xe0, 0x01, 0x00,\n"
|
5033 |
|
|
"0x00, 0xe0, 0x01, 0x00, 0x00, 0xc0, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,\n"
|
5034 |
|
|
"0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,\n"
|
5035 |
|
|
"0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,\n"
|
5036 |
|
|
"0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,\n"
|
5037 |
|
|
"0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};\"\n"
|
5038 |
|
|
"image create bitmap ::tk::dialog::i -foreground blue \\\n"
|
5039 |
|
|
"-data \"#define i_width 32\\n#define i_height 32\n"
|
5040 |
|
|
"static unsigned char i_bits[] = {\n"
|
5041 |
|
|
"0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,\n"
|
5042 |
|
|
"0x00, 0xe0, 0x01, 0x00, 0x00, 0xf0, 0x03, 0x00, 0x00, 0xf0, 0x03, 0x00,\n"
|
5043 |
|
|
"0x00, 0xe0, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,\n"
|
5044 |
|
|
"0x00, 0xf8, 0x03, 0x00, 0x00, 0xf0, 0x03, 0x00, 0x00, 0xe0, 0x03, 0x00,\n"
|
5045 |
|
|
"0x00, 0xe0, 0x03, 0x00, 0x00, 0xe0, 0x03, 0x00, 0x00, 0xe0, 0x03, 0x00,\n"
|
5046 |
|
|
"0x00, 0xe0, 0x03, 0x00, 0x00, 0xe0, 0x03, 0x00, 0x00, 0xf0, 0x07, 0x00,\n"
|
5047 |
|
|
"0x00, 0xf8, 0x0f, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,\n"
|
5048 |
|
|
"0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,\n"
|
5049 |
|
|
"0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,\n"
|
5050 |
|
|
"0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,\n"
|
5051 |
|
|
"0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};\"\n"
|
5052 |
|
|
"image create bitmap ::tk::dialog::w1 -foreground black \\\n"
|
5053 |
|
|
"-data \"#define w1_width 32\\n#define w1_height 32\n"
|
5054 |
|
|
"static unsigned char w1_bits[] = {\n"
|
5055 |
|
|
"0x00, 0x80, 0x01, 0x00, 0x00, 0x40, 0x02, 0x00, 0x00, 0x20, 0x04, 0x00,\n"
|
5056 |
|
|
"0x00, 0x10, 0x04, 0x00, 0x00, 0x10, 0x08, 0x00, 0x00, 0x08, 0x08, 0x00,\n"
|
5057 |
|
|
"0x00, 0x08, 0x10, 0x00, 0x00, 0x04, 0x10, 0x00, 0x00, 0x04, 0x20, 0x00,\n"
|
5058 |
|
|
"0x00, 0x02, 0x20, 0x00, 0x00, 0x02, 0x40, 0x00, 0x00, 0x01, 0x40, 0x00,\n"
|
5059 |
|
|
"0x00, 0x01, 0x80, 0x00, 0x80, 0x00, 0x80, 0x00, 0x80, 0x00, 0x00, 0x01,\n"
|
5060 |
|
|
"0x40, 0x00, 0x00, 0x01, 0x40, 0x00, 0x00, 0x02, 0x20, 0x00, 0x00, 0x02,\n"
|
5061 |
|
|
"0x20, 0x00, 0x00, 0x04, 0x10, 0x00, 0x00, 0x04, 0x10, 0x00, 0x00, 0x08,\n"
|
5062 |
|
|
"0x08, 0x00, 0x00, 0x08, 0x08, 0x00, 0x00, 0x10, 0x04, 0x00, 0x00, 0x10,\n"
|
5063 |
|
|
"0x04, 0x00, 0x00, 0x20, 0x02, 0x00, 0x00, 0x20, 0x01, 0x00, 0x00, 0x40,\n"
|
5064 |
|
|
"0x01, 0x00, 0x00, 0x40, 0x01, 0x00, 0x00, 0x40, 0x02, 0x00, 0x00, 0x20,\n"
|
5065 |
|
|
"0xfc, 0xff, 0xff, 0x1f, 0x00, 0x00, 0x00, 0x00};\"\n"
|
5066 |
|
|
"image create bitmap ::tk::dialog::w2 -foreground yellow \\\n"
|
5067 |
|
|
"-data \"#define w2_width 32\\n#define w2_height 32\n"
|
5068 |
|
|
"static unsigned char w2_bits[] = {\n"
|
5069 |
|
|
"0x00, 0x00, 0x00, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0xc0, 0x03, 0x00,\n"
|
5070 |
|
|
"0x00, 0xe0, 0x03, 0x00, 0x00, 0xe0, 0x07, 0x00, 0x00, 0xf0, 0x07, 0x00,\n"
|
5071 |
|
|
"0x00, 0xf0, 0x0f, 0x00, 0x00, 0xf8, 0x0f, 0x00, 0x00, 0xf8, 0x1f, 0x00,\n"
|
5072 |
|
|
"0x00, 0xfc, 0x1f, 0x00, 0x00, 0xfc, 0x3f, 0x00, 0x00, 0xfe, 0x3f, 0x00,\n"
|
5073 |
|
|
"0x00, 0xfe, 0x7f, 0x00, 0x00, 0xff, 0x7f, 0x00, 0x00, 0xff, 0xff, 0x00,\n"
|
5074 |
|
|
"0x80, 0xff, 0xff, 0x00, 0x80, 0xff, 0xff, 0x01, 0xc0, 0xff, 0xff, 0x01,\n"
|
5075 |
|
|
"0xc0, 0xff, 0xff, 0x03, 0xe0, 0xff, 0xff, 0x03, 0xe0, 0xff, 0xff, 0x07,\n"
|
5076 |
|
|
"0xf0, 0xff, 0xff, 0x07, 0xf0, 0xff, 0xff, 0x0f, 0xf8, 0xff, 0xff, 0x0f,\n"
|
5077 |
|
|
"0xf8, 0xff, 0xff, 0x1f, 0xfc, 0xff, 0xff, 0x1f, 0xfe, 0xff, 0xff, 0x3f,\n"
|
5078 |
|
|
"0xfe, 0xff, 0xff, 0x3f, 0xfe, 0xff, 0xff, 0x3f, 0xfc, 0xff, 0xff, 0x1f,\n"
|
5079 |
|
|
"0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};\"\n"
|
5080 |
|
|
"image create bitmap ::tk::dialog::w3 -foreground black \\\n"
|
5081 |
|
|
"-data \"#define w3_width 32\\n#define w3_height 32\n"
|
5082 |
|
|
"static unsigned char w3_bits[] = {\n"
|
5083 |
|
|
"0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,\n"
|
5084 |
|
|
"0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,\n"
|
5085 |
|
|
"0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,\n"
|
5086 |
|
|
"0x00, 0xc0, 0x03, 0x00, 0x00, 0xe0, 0x07, 0x00, 0x00, 0xe0, 0x07, 0x00,\n"
|
5087 |
|
|
"0x00, 0xe0, 0x07, 0x00, 0x00, 0xe0, 0x07, 0x00, 0x00, 0xe0, 0x07, 0x00,\n"
|
5088 |
|
|
"0x00, 0xc0, 0x03, 0x00, 0x00, 0xc0, 0x03, 0x00, 0x00, 0xc0, 0x03, 0x00,\n"
|
5089 |
|
|
"0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00,\n"
|
5090 |
|
|
"0x00, 0x00, 0x00, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0xc0, 0x03, 0x00,\n"
|
5091 |
|
|
"0x00, 0xc0, 0x03, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00,\n"
|
5092 |
|
|
"0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,\n"
|
5093 |
|
|
"0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};\"\n"
|
5094 |
|
|
"proc tkMessageBox {args} {\n"
|
5095 |
|
|
"global tkPriv tcl_platform tk_strictMotif\n"
|
5096 |
|
|
"set w tkPrivMsgBox\n"
|
5097 |
|
|
"upvar #0 $w data\n"
|
5098 |
|
|
"set specs {\n"
|
5099 |
|
|
"{-default \"\" \"\" \"\"}\n"
|
5100 |
|
|
"{-icon \"\" \"\" \"info\"}\n"
|
5101 |
|
|
"{-message \"\" \"\" \"\"}\n"
|
5102 |
|
|
"{-parent \"\" \"\" .}\n"
|
5103 |
|
|
"{-title \"\" \"\" \" \"}\n"
|
5104 |
|
|
"{-type \"\" \"\" \"ok\"}\n"
|
5105 |
|
|
"}\n"
|
5106 |
|
|
"tclParseConfigSpec $w $specs \"\" $args\n"
|
5107 |
|
|
"if {[lsearch -exact {info warning error question} $data(-icon)] == -1} {\n"
|
5108 |
|
|
"error \"bad -icon value \\\"$data(-icon)\\\": must be error, info, question, or warning\"\n"
|
5109 |
|
|
"}\n"
|
5110 |
|
|
"if {[string equal $tcl_platform(platform) \"macintosh\"]} {\n"
|
5111 |
|
|
"switch -- $data(-icon) {\n"
|
5112 |
|
|
"\"error\" {set data(-icon) \"stop\"}\n"
|
5113 |
|
|
"\"warning\" {set data(-icon) \"caution\"}\n"
|
5114 |
|
|
"\"info\" {set data(-icon) \"note\"}\n"
|
5115 |
|
|
"}\n"
|
5116 |
|
|
"}\n"
|
5117 |
|
|
"if {![winfo exists $data(-parent)]} {\n"
|
5118 |
|
|
"error \"bad window path name \\\"$data(-parent)\\\"\"\n"
|
5119 |
|
|
"}\n"
|
5120 |
|
|
"switch -- $data(-type) {\n"
|
5121 |
|
|
"abortretryignore {\n"
|
5122 |
|
|
"set buttons {\n"
|
5123 |
|
|
"{abort -width 6 -text Abort -under 0}\n"
|
5124 |
|
|
"{retry -width 6 -text Retry -under 0}\n"
|
5125 |
|
|
"{ignore -width 6 -text Ignore -under 0}\n"
|
5126 |
|
|
"}\n"
|
5127 |
|
|
"}\n"
|
5128 |
|
|
"ok {\n"
|
5129 |
|
|
"set buttons {\n"
|
5130 |
|
|
"{ok -width 6 -text OK -under 0}\n"
|
5131 |
|
|
"}\n"
|
5132 |
|
|
"if {[string equal $data(-default) \"\"]} {\n"
|
5133 |
|
|
"set data(-default) \"ok\"\n"
|
5134 |
|
|
"}\n"
|
5135 |
|
|
"}\n"
|
5136 |
|
|
"okcancel {\n"
|
5137 |
|
|
"set buttons {\n"
|
5138 |
|
|
"{ok -width 6 -text OK -under 0}\n"
|
5139 |
|
|
"{cancel -width 6 -text Cancel -under 0}\n"
|
5140 |
|
|
"}\n"
|
5141 |
|
|
"}\n"
|
5142 |
|
|
"retrycancel {\n"
|
5143 |
|
|
"set buttons {\n"
|
5144 |
|
|
"{retry -width 6 -text Retry -under 0}\n"
|
5145 |
|
|
"{cancel -width 6 -text Cancel -under 0}\n"
|
5146 |
|
|
"}\n"
|
5147 |
|
|
"}\n"
|
5148 |
|
|
"yesno {\n"
|
5149 |
|
|
"set buttons {\n"
|
5150 |
|
|
"{yes -width 6 -text Yes -under 0}\n"
|
5151 |
|
|
"{no -width 6 -text No -under 0}\n"
|
5152 |
|
|
"}\n"
|
5153 |
|
|
"}\n"
|
5154 |
|
|
"yesnocancel {\n"
|
5155 |
|
|
"set buttons {\n"
|
5156 |
|
|
"{yes -width 6 -text Yes -under 0}\n"
|
5157 |
|
|
"{no -width 6 -text No -under 0}\n"
|
5158 |
|
|
"{cancel -width 6 -text Cancel -under 0}\n"
|
5159 |
|
|
"}\n"
|
5160 |
|
|
"}\n"
|
5161 |
|
|
"default {\n"
|
5162 |
|
|
"error \"bad -type value \\\"$data(-type)\\\": must be abortretryignore, ok, okcancel, retrycancel, yesno, or yesnocancel\"\n"
|
5163 |
|
|
"}\n"
|
5164 |
|
|
"}\n"
|
5165 |
|
|
"if {[string compare $data(-default) \"\"]} {\n"
|
5166 |
|
|
"set valid 0\n"
|
5167 |
|
|
"foreach btn $buttons {\n"
|
5168 |
|
|
"if {[string equal [lindex $btn 0] $data(-default)]} {\n"
|
5169 |
|
|
"set valid 1\n"
|
5170 |
|
|
"break\n"
|
5171 |
|
|
"}\n"
|
5172 |
|
|
"}\n"
|
5173 |
|
|
"if {!$valid} {\n"
|
5174 |
|
|
"error \"invalid default button \\\"$data(-default)\\\"\"\n"
|
5175 |
|
|
"}\n"
|
5176 |
|
|
"}\n"
|
5177 |
|
|
"if {[string compare $data(-parent) .]} {\n"
|
5178 |
|
|
"set w $data(-parent).__tk__messagebox\n"
|
5179 |
|
|
"} else {\n"
|
5180 |
|
|
"set w .__tk__messagebox\n"
|
5181 |
|
|
"}\n"
|
5182 |
|
|
"catch {destroy $w}\n"
|
5183 |
|
|
"toplevel $w -class Dialog\n"
|
5184 |
|
|
"wm title $w $data(-title)\n"
|
5185 |
|
|
"wm iconname $w Dialog\n"
|
5186 |
|
|
"wm protocol $w WM_DELETE_WINDOW { }\n"
|
5187 |
|
|
"if { [winfo viewable [winfo toplevel $data(-parent)]] } {\n"
|
5188 |
|
|
"wm transient $w $data(-parent)\n"
|
5189 |
|
|
"} \n"
|
5190 |
|
|
"if {[string equal $tcl_platform(platform) \"macintosh\"]} {\n"
|
5191 |
|
|
"unsupported1 style $w dBoxProc\n"
|
5192 |
|
|
"}\n"
|
5193 |
|
|
"frame $w.bot\n"
|
5194 |
|
|
"pack $w.bot -side bottom -fill both\n"
|
5195 |
|
|
"frame $w.top\n"
|
5196 |
|
|
"pack $w.top -side top -fill both -expand 1\n"
|
5197 |
|
|
"if {[string compare $tcl_platform(platform) \"macintosh\"]} {\n"
|
5198 |
|
|
"$w.bot configure -relief raised -bd 1\n"
|
5199 |
|
|
"$w.top configure -relief raised -bd 1\n"
|
5200 |
|
|
"}\n"
|
5201 |
|
|
"option add *Dialog.msg.wrapLength 3i widgetDefault\n"
|
5202 |
|
|
"if {[string equal $tcl_platform(platform) \"macintosh\"]} {\n"
|
5203 |
|
|
"option add *Dialog.msg.font system widgetDefault\n"
|
5204 |
|
|
"} else {\n"
|
5205 |
|
|
"option add *Dialog.msg.font {Times 18} widgetDefault\n"
|
5206 |
|
|
"}\n"
|
5207 |
|
|
"label $w.msg -anchor nw -justify left -text $data(-message)\n"
|
5208 |
|
|
"if {[string compare $data(-icon) \"\"]} {\n"
|
5209 |
|
|
"if {[string equal $tcl_platform(platform) \"macintosh\"] \\\n"
|
5210 |
|
|
"\011\011|| ([winfo depth $w] < 4) || $tk_strictMotif} {\n"
|
5211 |
|
|
"label $w.bitmap -bitmap $data(-icon)\n"
|
5212 |
|
|
"} else {\n"
|
5213 |
|
|
"canvas $w.bitmap -width 32 -height 32 -highlightthickness 0\n"
|
5214 |
|
|
"switch $data(-icon) {\n"
|
5215 |
|
|
"error {\n"
|
5216 |
|
|
"$w.bitmap create oval 0 0 31 31 -fill red -outline black\n"
|
5217 |
|
|
"$w.bitmap create line 9 9 23 23 -fill white -width 4\n"
|
5218 |
|
|
"$w.bitmap create line 9 23 23 9 -fill white -width 4\n"
|
5219 |
|
|
"}\n"
|
5220 |
|
|
"info {\n"
|
5221 |
|
|
"$w.bitmap create image 0 0 -anchor nw \\\n"
|
5222 |
|
|
"\011\011\011 -image ::tk::dialog::b1\n"
|
5223 |
|
|
"$w.bitmap create image 0 0 -anchor nw \\\n"
|
5224 |
|
|
"\011\011\011 -image ::tk::dialog::b2\n"
|
5225 |
|
|
"$w.bitmap create image 0 0 -anchor nw \\\n"
|
5226 |
|
|
"\011\011\011 -image ::tk::dialog::i\n"
|
5227 |
|
|
"}\n"
|
5228 |
|
|
"question {\n"
|
5229 |
|
|
"$w.bitmap create image 0 0 -anchor nw \\\n"
|
5230 |
|
|
"\011\011\011 -image ::tk::dialog::b1\n"
|
5231 |
|
|
"$w.bitmap create image 0 0 -anchor nw \\\n"
|
5232 |
|
|
"\011\011\011 -image ::tk::dialog::b2\n"
|
5233 |
|
|
"$w.bitmap create image 0 0 -anchor nw \\\n"
|
5234 |
|
|
"\011\011\011 -image ::tk::dialog::q\n"
|
5235 |
|
|
"}\n"
|
5236 |
|
|
"default {\n"
|
5237 |
|
|
"$w.bitmap create image 0 0 -anchor nw \\\n"
|
5238 |
|
|
"\011\011\011 -image ::tk::dialog::w1\n"
|
5239 |
|
|
"$w.bitmap create image 0 0 -anchor nw \\\n"
|
5240 |
|
|
"\011\011\011 -image ::tk::dialog::w2\n"
|
5241 |
|
|
"$w.bitmap create image 0 0 -anchor nw \\\n"
|
5242 |
|
|
"\011\011\011 -image ::tk::dialog::w3\n"
|
5243 |
|
|
"}\n"
|
5244 |
|
|
"}\n"
|
5245 |
|
|
"}\n"
|
5246 |
|
|
"}\n"
|
5247 |
|
|
"grid $w.bitmap $w.msg -in $w.top -sticky news -padx 2m -pady 2m\n"
|
5248 |
|
|
"grid columnconfigure $w.top 1 -weight 1\n"
|
5249 |
|
|
"grid rowconfigure $w.top 0 -weight 1\n"
|
5250 |
|
|
"set i 0\n"
|
5251 |
|
|
"foreach but $buttons {\n"
|
5252 |
|
|
"set name [lindex $but 0]\n"
|
5253 |
|
|
"set opts [lrange $but 1 end]\n"
|
5254 |
|
|
"if {![llength $opts]} {\n"
|
5255 |
|
|
"set capName [string toupper $name 0]\n"
|
5256 |
|
|
"set opts [list -text $capName]\n"
|
5257 |
|
|
"}\n"
|
5258 |
|
|
"eval button [list $w.$name] $opts [list -command [list set tkPriv(button) $name]]\n"
|
5259 |
|
|
"if {[string equal $name $data(-default)]} {\n"
|
5260 |
|
|
"$w.$name configure -default active\n"
|
5261 |
|
|
"}\n"
|
5262 |
|
|
"pack $w.$name -in $w.bot -side left -expand 1 -padx 3m -pady 2m\n"
|
5263 |
|
|
"set underIdx [$w.$name cget -under]\n"
|
5264 |
|
|
"if {$underIdx >= 0} {\n"
|
5265 |
|
|
"set key [string index [$w.$name cget -text] $underIdx]\n"
|
5266 |
|
|
"bind $w <Alt-[string tolower $key]> [list $w.$name invoke]\n"
|
5267 |
|
|
"bind $w <Alt-[string toupper $key]> [list $w.$name invoke]\n"
|
5268 |
|
|
"}\n"
|
5269 |
|
|
"incr i\n"
|
5270 |
|
|
"}\n"
|
5271 |
|
|
"if {[string compare {} $data(-default)]} {\n"
|
5272 |
|
|
"bind $w <FocusIn> {\n"
|
5273 |
|
|
"if {[string equal Button [winfo class %W]]} {\n"
|
5274 |
|
|
"%W configure -default active\n"
|
5275 |
|
|
"}\n"
|
5276 |
|
|
"}\n"
|
5277 |
|
|
"bind $w <FocusOut> {\n"
|
5278 |
|
|
"if {[string equal Button [winfo class %W]]} {\n"
|
5279 |
|
|
"%W configure -default normal\n"
|
5280 |
|
|
"}\n"
|
5281 |
|
|
"}\n"
|
5282 |
|
|
"}\n"
|
5283 |
|
|
"bind $w <Return> {\n"
|
5284 |
|
|
"if {[string equal Button [winfo class %W]]} {\n"
|
5285 |
|
|
"tkButtonInvoke %W\n"
|
5286 |
|
|
"}\n"
|
5287 |
|
|
"}\n"
|
5288 |
|
|
"::tk::PlaceWindow $w widget $data(-parent)\n"
|
5289 |
|
|
"if {[string compare $data(-default) \"\"]} {\n"
|
5290 |
|
|
"set focus $w.$data(-default)\n"
|
5291 |
|
|
"} else {\n"
|
5292 |
|
|
"set focus $w\n"
|
5293 |
|
|
"}\n"
|
5294 |
|
|
"::tk::SetFocusGrab $w $focus\n"
|
5295 |
|
|
"tkwait variable tkPriv(button)\n"
|
5296 |
|
|
"::tk::RestoreFocusGrab $w $focus\n"
|
5297 |
|
|
"return $tkPriv(button)\n"
|
5298 |
|
|
"}\n"
|
5299 |
|
|
;
|
5300 |
|
|
static char Et_zFile19[] =
|
5301 |
|
|
"proc tk_menuBar args {}\n"
|
5302 |
|
|
"proc tk_bindForTraversal args {}\n"
|
5303 |
|
|
;
|
5304 |
|
|
static char Et_zFile20[] =
|
5305 |
|
|
"proc tk_optionMenu {w varName firstValue args} {\n"
|
5306 |
|
|
"upvar #0 $varName var\n"
|
5307 |
|
|
"if {![info exists var]} {\n"
|
5308 |
|
|
"set var $firstValue\n"
|
5309 |
|
|
"}\n"
|
5310 |
|
|
"menubutton $w -textvariable $varName -indicatoron 1 -menu $w.menu \\\n"
|
5311 |
|
|
"\011 -relief raised -bd 2 -highlightthickness 2 -anchor c \\\n"
|
5312 |
|
|
"\011 -direction flush\n"
|
5313 |
|
|
"menu $w.menu -tearoff 0\n"
|
5314 |
|
|
"$w.menu add radiobutton -label $firstValue -variable $varName\n"
|
5315 |
|
|
"foreach i $args {\n"
|
5316 |
|
|
"$w.menu add radiobutton -label $i -variable $varName\n"
|
5317 |
|
|
"}\n"
|
5318 |
|
|
"return $w.menu\n"
|
5319 |
|
|
"}\n"
|
5320 |
|
|
;
|
5321 |
|
|
static char Et_zFile21[] =
|
5322 |
|
|
"proc tk_setPalette {args} {\n"
|
5323 |
|
|
"if {[winfo depth .] == 1} {\n"
|
5324 |
|
|
"return\n"
|
5325 |
|
|
"}\n"
|
5326 |
|
|
"global tkPalette\n"
|
5327 |
|
|
"if {[llength $args] == 1} {\n"
|
5328 |
|
|
"set new(background) [lindex $args 0]\n"
|
5329 |
|
|
"} else {\n"
|
5330 |
|
|
"array set new $args\n"
|
5331 |
|
|
"}\n"
|
5332 |
|
|
"if {![info exists new(background)]} {\n"
|
5333 |
|
|
"error \"must specify a background color\"\n"
|
5334 |
|
|
"}\n"
|
5335 |
|
|
"if {![info exists new(foreground)]} {\n"
|
5336 |
|
|
"set new(foreground) black\n"
|
5337 |
|
|
"}\n"
|
5338 |
|
|
"set bg [winfo rgb . $new(background)]\n"
|
5339 |
|
|
"set fg [winfo rgb . $new(foreground)]\n"
|
5340 |
|
|
"set darkerBg [format #%02x%02x%02x [expr {(9*[lindex $bg 0])/2560}] \\\n"
|
5341 |
|
|
"\011 [expr {(9*[lindex $bg 1])/2560}] [expr {(9*[lindex $bg 2])/2560}]]\n"
|
5342 |
|
|
"foreach i {activeForeground insertBackground selectForeground \\\n"
|
5343 |
|
|
"\011 highlightColor} {\n"
|
5344 |
|
|
"if {![info exists new($i)]} {\n"
|
5345 |
|
|
"set new($i) $new(foreground)\n"
|
5346 |
|
|
"}\n"
|
5347 |
|
|
"}\n"
|
5348 |
|
|
"if {![info exists new(disabledForeground)]} {\n"
|
5349 |
|
|
"set new(disabledForeground) [format #%02x%02x%02x \\\n"
|
5350 |
|
|
"\011\011[expr {(3*[lindex $bg 0] + [lindex $fg 0])/1024}] \\\n"
|
5351 |
|
|
"\011\011[expr {(3*[lindex $bg 1] + [lindex $fg 1])/1024}] \\\n"
|
5352 |
|
|
"\011\011[expr {(3*[lindex $bg 2] + [lindex $fg 2])/1024}]]\n"
|
5353 |
|
|
"}\n"
|
5354 |
|
|
"if {![info exists new(highlightBackground)]} {\n"
|
5355 |
|
|
"set new(highlightBackground) $new(background)\n"
|
5356 |
|
|
"}\n"
|
5357 |
|
|
"if {![info exists new(activeBackground)]} {\n"
|
5358 |
|
|
"foreach i {0 1 2} {\n"
|
5359 |
|
|
"set light($i) [expr {[lindex $bg $i]/256}]\n"
|
5360 |
|
|
"set inc1 [expr {($light($i)*15)/100}]\n"
|
5361 |
|
|
"set inc2 [expr {(255-$light($i))/3}]\n"
|
5362 |
|
|
"if {$inc1 > $inc2} {\n"
|
5363 |
|
|
"incr light($i) $inc1\n"
|
5364 |
|
|
"} else {\n"
|
5365 |
|
|
"incr light($i) $inc2\n"
|
5366 |
|
|
"}\n"
|
5367 |
|
|
"if {$light($i) > 255} {\n"
|
5368 |
|
|
"set light($i) 255\n"
|
5369 |
|
|
"}\n"
|
5370 |
|
|
"}\n"
|
5371 |
|
|
"set new(activeBackground) [format #%02x%02x%02x $light(0) \\\n"
|
5372 |
|
|
"\011\011$light(1) $light(2)]\n"
|
5373 |
|
|
"}\n"
|
5374 |
|
|
"if {![info exists new(selectBackground)]} {\n"
|
5375 |
|
|
"set new(selectBackground) $darkerBg\n"
|
5376 |
|
|
"}\n"
|
5377 |
|
|
"if {![info exists new(troughColor)]} {\n"
|
5378 |
|
|
"set new(troughColor) $darkerBg\n"
|
5379 |
|
|
"}\n"
|
5380 |
|
|
"if {![info exists new(selectColor)]} {\n"
|
5381 |
|
|
"set new(selectColor) #b03060\n"
|
5382 |
|
|
"}\n"
|
5383 |
|
|
"toplevel .___tk_set_palette\n"
|
5384 |
|
|
"wm withdraw .___tk_set_palette\n"
|
5385 |
|
|
"foreach q {button canvas checkbutton entry frame label listbox \\\n"
|
5386 |
|
|
"\011 menubutton menu message radiobutton scale scrollbar text} {\n"
|
5387 |
|
|
"$q .___tk_set_palette.$q\n"
|
5388 |
|
|
"}\n"
|
5389 |
|
|
"eval [tkRecolorTree . new]\n"
|
5390 |
|
|
"catch {destroy .___tk_set_palette}\n"
|
5391 |
|
|
"foreach option [array names new] {\n"
|
5392 |
|
|
"option add *$option $new($option) widgetDefault\n"
|
5393 |
|
|
"}\n"
|
5394 |
|
|
"array set tkPalette [array get new]\n"
|
5395 |
|
|
"}\n"
|
5396 |
|
|
"proc tkRecolorTree {w colors} {\n"
|
5397 |
|
|
"global tkPalette\n"
|
5398 |
|
|
"upvar $colors c\n"
|
5399 |
|
|
"set result {}\n"
|
5400 |
|
|
"foreach dbOption [array names c] {\n"
|
5401 |
|
|
"set option -[string tolower $dbOption]\n"
|
5402 |
|
|
"if {![catch {$w config $option} value]} {\n"
|
5403 |
|
|
"set defaultcolor [option get $w $dbOption widgetDefault]\n"
|
5404 |
|
|
"if {[string match {} $defaultcolor]} {\n"
|
5405 |
|
|
"set defaultcolor [winfo rgb . [lindex $value 3]]\n"
|
5406 |
|
|
"} else {\n"
|
5407 |
|
|
"set defaultcolor [winfo rgb . $defaultcolor]\n"
|
5408 |
|
|
"}\n"
|
5409 |
|
|
"set chosencolor [winfo rgb . [lindex $value 4]]\n"
|
5410 |
|
|
"if {[string match $defaultcolor $chosencolor]} {\n"
|
5411 |
|
|
"append result \";\\noption add [list \\\n"
|
5412 |
|
|
"\011\011 *[winfo class $w].$dbOption $c($dbOption) 60]\"\n"
|
5413 |
|
|
"$w configure $option $c($dbOption)\n"
|
5414 |
|
|
"}\n"
|
5415 |
|
|
"}\n"
|
5416 |
|
|
"}\n"
|
5417 |
|
|
"foreach child [winfo children $w] {\n"
|
5418 |
|
|
"append result \";\\n[tkRecolorTree $child c]\"\n"
|
5419 |
|
|
"}\n"
|
5420 |
|
|
"return $result\n"
|
5421 |
|
|
"}\n"
|
5422 |
|
|
"proc tkDarken {color percent} {\n"
|
5423 |
|
|
"foreach {red green blue} [winfo rgb . $color] {\n"
|
5424 |
|
|
"set red [expr {($red/256)*$percent/100}]\n"
|
5425 |
|
|
"set green [expr {($green/256)*$percent/100}]\n"
|
5426 |
|
|
"set blue [expr {($blue/256)*$percent/100}]\n"
|
5427 |
|
|
"break\n"
|
5428 |
|
|
"}\n"
|
5429 |
|
|
"if {$red > 255} {\n"
|
5430 |
|
|
"set red 255\n"
|
5431 |
|
|
"}\n"
|
5432 |
|
|
"if {$green > 255} {\n"
|
5433 |
|
|
"set green 255\n"
|
5434 |
|
|
"}\n"
|
5435 |
|
|
"if {$blue > 255} {\n"
|
5436 |
|
|
"set blue 255\n"
|
5437 |
|
|
"}\n"
|
5438 |
|
|
"return [format \"#%02x%02x%02x\" $red $green $blue]\n"
|
5439 |
|
|
"}\n"
|
5440 |
|
|
"proc tk_bisque {} {\n"
|
5441 |
|
|
"tk_setPalette activeBackground #e6ceb1 activeForeground black \\\n"
|
5442 |
|
|
"\011 background #ffe4c4 disabledForeground #b0b0b0 foreground black \\\n"
|
5443 |
|
|
"\011 highlightBackground #ffe4c4 highlightColor black \\\n"
|
5444 |
|
|
"\011 insertBackground black selectColor #b03060 \\\n"
|
5445 |
|
|
"\011 selectBackground #e6ceb1 selectForeground black \\\n"
|
5446 |
|
|
"\011 troughColor #cdb79e\n"
|
5447 |
|
|
"}\n"
|
5448 |
|
|
;
|
5449 |
|
|
static char Et_zFile22[] =
|
5450 |
|
|
"package require opt 0.4.1;\n"
|
5451 |
|
|
"namespace eval ::safe {\n"
|
5452 |
|
|
"variable tkSafeId 0;\n"
|
5453 |
|
|
"proc ::safe::tkInterpInit {slave argv} {\n"
|
5454 |
|
|
"global env tk_library\n"
|
5455 |
|
|
"allowTk $slave $argv\n"
|
5456 |
|
|
"::interp eval $slave [list set tk_library [::safe::interpAddToAccessPath $slave $tk_library]]\n"
|
5457 |
|
|
"return $slave\n"
|
5458 |
|
|
"}\n"
|
5459 |
|
|
"proc ::safe::loadTk {} {}\n"
|
5460 |
|
|
"::tcl::OptProc loadTk {\n"
|
5461 |
|
|
"{slave -interp \"name of the slave interpreter\"}\n"
|
5462 |
|
|
"{-use -windowId {} \"window Id to use (new toplevel otherwise)\"}\n"
|
5463 |
|
|
"{-display -displayName {} \"display name to use (current one otherwise)\"}\n"
|
5464 |
|
|
"} {\n"
|
5465 |
|
|
"set displayGiven [::tcl::OptProcArgGiven \"-display\"]\n"
|
5466 |
|
|
"if {!$displayGiven} {\n"
|
5467 |
|
|
"if {[catch {set display [winfo screen .]}]} {\n"
|
5468 |
|
|
"if {[info exists ::env(DISPLAY)]} {\n"
|
5469 |
|
|
"set display $::env(DISPLAY)\n"
|
5470 |
|
|
"} else {\n"
|
5471 |
|
|
"Log $slave \"no winfo screen . nor env(DISPLAY)\" WARNING\n"
|
5472 |
|
|
"set display \":0.0\"\n"
|
5473 |
|
|
"}\n"
|
5474 |
|
|
"}\n"
|
5475 |
|
|
"}\n"
|
5476 |
|
|
"if {![::tcl::OptProcArgGiven \"-use\"]} {\n"
|
5477 |
|
|
"::tcl::Lassign [tkTopLevel $slave $display] w use\n"
|
5478 |
|
|
"Set [DeleteHookName $slave] [list tkDelete {} $w]\n"
|
5479 |
|
|
"} else {\n"
|
5480 |
|
|
"Set [DeleteHookName $slave] [list disallowTk]\n"
|
5481 |
|
|
"if {[string match \".*\" $use]} {\n"
|
5482 |
|
|
"set windowName $use\n"
|
5483 |
|
|
"set use [winfo id $windowName]\n"
|
5484 |
|
|
"set nDisplay [winfo screen $windowName]\n"
|
5485 |
|
|
"} else {\n"
|
5486 |
|
|
"if {![catch {winfo pathname $use} name]} {\n"
|
5487 |
|
|
"set nDisplay [winfo screen $name]\n"
|
5488 |
|
|
"} else {\n"
|
5489 |
|
|
"set nDisplay $display\n"
|
5490 |
|
|
"}\n"
|
5491 |
|
|
"}\n"
|
5492 |
|
|
"if {[string compare $nDisplay $display]} {\n"
|
5493 |
|
|
"if {$displayGiven} {\n"
|
5494 |
|
|
"error \"conflicting -display $display and -use\\\n"
|
5495 |
|
|
"\011\011\011$use -> $nDisplay\"\n"
|
5496 |
|
|
"} else {\n"
|
5497 |
|
|
"set display $nDisplay\n"
|
5498 |
|
|
"}\n"
|
5499 |
|
|
"}\n"
|
5500 |
|
|
"}\n"
|
5501 |
|
|
"tkInterpInit $slave [list \"-use\" $use \"-display\" $display]\n"
|
5502 |
|
|
"load {} Tk $slave\n"
|
5503 |
|
|
"return $slave\n"
|
5504 |
|
|
"}\n"
|
5505 |
|
|
"proc ::safe::TkInit {interpPath} {\n"
|
5506 |
|
|
"variable tkInit\n"
|
5507 |
|
|
"if {[info exists tkInit($interpPath)]} {\n"
|
5508 |
|
|
"set value $tkInit($interpPath)\n"
|
5509 |
|
|
"Log $interpPath \"TkInit called, returning \\\"$value\\\"\" NOTICE\n"
|
5510 |
|
|
"return $value\n"
|
5511 |
|
|
"} else {\n"
|
5512 |
|
|
"Log $interpPath \"TkInit called for interp with clearance:\\\n"
|
5513 |
|
|
"\011\011preventing Tk init\" ERROR\n"
|
5514 |
|
|
"error \"not allowed\"\n"
|
5515 |
|
|
"}\n"
|
5516 |
|
|
"}\n"
|
5517 |
|
|
"proc ::safe::allowTk {interpPath argv} {\n"
|
5518 |
|
|
"variable tkInit\n"
|
5519 |
|
|
"set tkInit($interpPath) $argv\n"
|
5520 |
|
|
"return\n"
|
5521 |
|
|
"}\n"
|
5522 |
|
|
"proc ::safe::disallowTk {interpPath} {\n"
|
5523 |
|
|
"variable tkInit\n"
|
5524 |
|
|
"if {[info exists tkInit($interpPath)]} {\n"
|
5525 |
|
|
"unset tkInit($interpPath)\n"
|
5526 |
|
|
"}\n"
|
5527 |
|
|
"return\n"
|
5528 |
|
|
"}\n"
|
5529 |
|
|
"proc ::safe::tkDelete {W window slave} {\n"
|
5530 |
|
|
"Log $slave \"Called tkDelete $W $window\" NOTICE\n"
|
5531 |
|
|
"if {[::interp exists $slave]} {\n"
|
5532 |
|
|
"if {[catch {::safe::interpDelete $slave} msg]} {\n"
|
5533 |
|
|
"Log $slave \"Deletion error : $msg\"\n"
|
5534 |
|
|
"}\n"
|
5535 |
|
|
"}\n"
|
5536 |
|
|
"if {[winfo exists $window]} {\n"
|
5537 |
|
|
"Log $slave \"Destroy toplevel $window\" NOTICE\n"
|
5538 |
|
|
"destroy $window\n"
|
5539 |
|
|
"}\n"
|
5540 |
|
|
"disallowTk $slave\n"
|
5541 |
|
|
"return\n"
|
5542 |
|
|
"}\n"
|
5543 |
|
|
"proc ::safe::tkTopLevel {slave display} {\n"
|
5544 |
|
|
"variable tkSafeId\n"
|
5545 |
|
|
"incr tkSafeId\n"
|
5546 |
|
|
"set w \".safe$tkSafeId\"\n"
|
5547 |
|
|
"if {[catch {toplevel $w -screen $display -class SafeTk} msg]} {\n"
|
5548 |
|
|
"return -code error \"Unable to create toplevel for\\\n"
|
5549 |
|
|
"\011\011safe slave \\\"$slave\\\" ($msg)\"\n"
|
5550 |
|
|
"}\n"
|
5551 |
|
|
"Log $slave \"New toplevel $w\" NOTICE\n"
|
5552 |
|
|
"set msg \"Untrusted Tcl applet ($slave)\"\n"
|
5553 |
|
|
"wm title $w $msg\n"
|
5554 |
|
|
"set wc $w.fc\n"
|
5555 |
|
|
"frame $wc -bg red -borderwidth 3 -relief ridge\n"
|
5556 |
|
|
"bindtags $wc [concat Safe$wc [bindtags $wc]]\n"
|
5557 |
|
|
"bind Safe$wc <Destroy> [list ::safe::tkDelete %W $w $slave]\n"
|
5558 |
|
|
"label $wc.l -text $msg -padx 2 -pady 0 -anchor w\n"
|
5559 |
|
|
"frame $wc.fb -bd 0\n"
|
5560 |
|
|
"button $wc.fb.b -text \"Delete\" \\\n"
|
5561 |
|
|
"\011 -bd 1 -padx 2 -pady 0 -highlightthickness 0 \\\n"
|
5562 |
|
|
"\011 -command [list ::safe::tkDelete $w $w $slave]\n"
|
5563 |
|
|
"pack $wc.fb.b -side right -fill both\n"
|
5564 |
|
|
"pack $wc.fb -side right -fill both -expand 1\n"
|
5565 |
|
|
"pack $wc.l -side left -fill both -expand 1\n"
|
5566 |
|
|
"pack $wc -side bottom -fill x\n"
|
5567 |
|
|
"frame $w.c -container 1\n"
|
5568 |
|
|
"pack $w.c -fill both -expand 1\n"
|
5569 |
|
|
"list $w [winfo id $w.c]\n"
|
5570 |
|
|
"}\n"
|
5571 |
|
|
"}\n"
|
5572 |
|
|
;
|
5573 |
|
|
static char Et_zFile23[] =
|
5574 |
|
|
"bind Scale <Enter> {\n"
|
5575 |
|
|
"if {$tk_strictMotif} {\n"
|
5576 |
|
|
"set tkPriv(activeBg) [%W cget -activebackground]\n"
|
5577 |
|
|
"%W config -activebackground [%W cget -background]\n"
|
5578 |
|
|
"}\n"
|
5579 |
|
|
"tkScaleActivate %W %x %y\n"
|
5580 |
|
|
"}\n"
|
5581 |
|
|
"bind Scale <Motion> {\n"
|
5582 |
|
|
"tkScaleActivate %W %x %y\n"
|
5583 |
|
|
"}\n"
|
5584 |
|
|
"bind Scale <Leave> {\n"
|
5585 |
|
|
"if {$tk_strictMotif} {\n"
|
5586 |
|
|
"%W config -activebackground $tkPriv(activeBg)\n"
|
5587 |
|
|
"}\n"
|
5588 |
|
|
"if {[string equal [%W cget -state] \"active\"]} {\n"
|
5589 |
|
|
"%W configure -state normal\n"
|
5590 |
|
|
"}\n"
|
5591 |
|
|
"}\n"
|
5592 |
|
|
"bind Scale <1> {\n"
|
5593 |
|
|
"tkScaleButtonDown %W %x %y\n"
|
5594 |
|
|
"}\n"
|
5595 |
|
|
"bind Scale <B1-Motion> {\n"
|
5596 |
|
|
"tkScaleDrag %W %x %y\n"
|
5597 |
|
|
"}\n"
|
5598 |
|
|
"bind Scale <B1-Leave> { }\n"
|
5599 |
|
|
"bind Scale <B1-Enter> { }\n"
|
5600 |
|
|
"bind Scale <ButtonRelease-1> {\n"
|
5601 |
|
|
"tkCancelRepeat\n"
|
5602 |
|
|
"tkScaleEndDrag %W\n"
|
5603 |
|
|
"tkScaleActivate %W %x %y\n"
|
5604 |
|
|
"}\n"
|
5605 |
|
|
"bind Scale <2> {\n"
|
5606 |
|
|
"tkScaleButton2Down %W %x %y\n"
|
5607 |
|
|
"}\n"
|
5608 |
|
|
"bind Scale <B2-Motion> {\n"
|
5609 |
|
|
"tkScaleDrag %W %x %y\n"
|
5610 |
|
|
"}\n"
|
5611 |
|
|
"bind Scale <B2-Leave> { }\n"
|
5612 |
|
|
"bind Scale <B2-Enter> { }\n"
|
5613 |
|
|
"bind Scale <ButtonRelease-2> {\n"
|
5614 |
|
|
"tkCancelRepeat\n"
|
5615 |
|
|
"tkScaleEndDrag %W\n"
|
5616 |
|
|
"tkScaleActivate %W %x %y\n"
|
5617 |
|
|
"}\n"
|
5618 |
|
|
"bind Scale <Control-1> {\n"
|
5619 |
|
|
"tkScaleControlPress %W %x %y\n"
|
5620 |
|
|
"}\n"
|
5621 |
|
|
"bind Scale <Up> {\n"
|
5622 |
|
|
"tkScaleIncrement %W up little noRepeat\n"
|
5623 |
|
|
"}\n"
|
5624 |
|
|
"bind Scale <Down> {\n"
|
5625 |
|
|
"tkScaleIncrement %W down little noRepeat\n"
|
5626 |
|
|
"}\n"
|
5627 |
|
|
"bind Scale <Left> {\n"
|
5628 |
|
|
"tkScaleIncrement %W up little noRepeat\n"
|
5629 |
|
|
"}\n"
|
5630 |
|
|
"bind Scale <Right> {\n"
|
5631 |
|
|
"tkScaleIncrement %W down little noRepeat\n"
|
5632 |
|
|
"}\n"
|
5633 |
|
|
"bind Scale <Control-Up> {\n"
|
5634 |
|
|
"tkScaleIncrement %W up big noRepeat\n"
|
5635 |
|
|
"}\n"
|
5636 |
|
|
"bind Scale <Control-Down> {\n"
|
5637 |
|
|
"tkScaleIncrement %W down big noRepeat\n"
|
5638 |
|
|
"}\n"
|
5639 |
|
|
"bind Scale <Control-Left> {\n"
|
5640 |
|
|
"tkScaleIncrement %W up big noRepeat\n"
|
5641 |
|
|
"}\n"
|
5642 |
|
|
"bind Scale <Control-Right> {\n"
|
5643 |
|
|
"tkScaleIncrement %W down big noRepeat\n"
|
5644 |
|
|
"}\n"
|
5645 |
|
|
"bind Scale <Home> {\n"
|
5646 |
|
|
"%W set [%W cget -from]\n"
|
5647 |
|
|
"}\n"
|
5648 |
|
|
"bind Scale <End> {\n"
|
5649 |
|
|
"%W set [%W cget -to]\n"
|
5650 |
|
|
"}\n"
|
5651 |
|
|
"proc tkScaleActivate {w x y} {\n"
|
5652 |
|
|
"if {[string equal [$w cget -state] \"disabled\"]} {\n"
|
5653 |
|
|
"return\n"
|
5654 |
|
|
"}\n"
|
5655 |
|
|
"if {[string equal [$w identify $x $y] \"slider\"]} {\n"
|
5656 |
|
|
"set state active\n"
|
5657 |
|
|
"} else {\n"
|
5658 |
|
|
"set state normal\n"
|
5659 |
|
|
"}\n"
|
5660 |
|
|
"if {[string compare [$w cget -state] $state]} {\n"
|
5661 |
|
|
"$w configure -state $state\n"
|
5662 |
|
|
"}\n"
|
5663 |
|
|
"}\n"
|
5664 |
|
|
"proc tkScaleButtonDown {w x y} {\n"
|
5665 |
|
|
"global tkPriv\n"
|
5666 |
|
|
"set tkPriv(dragging) 0\n"
|
5667 |
|
|
"set el [$w identify $x $y]\n"
|
5668 |
|
|
"if {[string equal $el \"trough1\"]} {\n"
|
5669 |
|
|
"tkScaleIncrement $w up little initial\n"
|
5670 |
|
|
"} elseif {[string equal $el \"trough2\"]} {\n"
|
5671 |
|
|
"tkScaleIncrement $w down little initial\n"
|
5672 |
|
|
"} elseif {[string equal $el \"slider\"]} {\n"
|
5673 |
|
|
"set tkPriv(dragging) 1\n"
|
5674 |
|
|
"set tkPriv(initValue) [$w get]\n"
|
5675 |
|
|
"set coords [$w coords]\n"
|
5676 |
|
|
"set tkPriv(deltaX) [expr {$x - [lindex $coords 0]}]\n"
|
5677 |
|
|
"set tkPriv(deltaY) [expr {$y - [lindex $coords 1]}]\n"
|
5678 |
|
|
"$w configure -sliderrelief sunken\n"
|
5679 |
|
|
"}\n"
|
5680 |
|
|
"}\n"
|
5681 |
|
|
"proc tkScaleDrag {w x y} {\n"
|
5682 |
|
|
"global tkPriv\n"
|
5683 |
|
|
"if {!$tkPriv(dragging)} {\n"
|
5684 |
|
|
"return\n"
|
5685 |
|
|
"}\n"
|
5686 |
|
|
"$w set [$w get [expr {$x-$tkPriv(deltaX)}] [expr {$y-$tkPriv(deltaY)}]]\n"
|
5687 |
|
|
"}\n"
|
5688 |
|
|
"proc tkScaleEndDrag {w} {\n"
|
5689 |
|
|
"global tkPriv\n"
|
5690 |
|
|
"set tkPriv(dragging) 0\n"
|
5691 |
|
|
"$w configure -sliderrelief raised\n"
|
5692 |
|
|
"}\n"
|
5693 |
|
|
"proc tkScaleIncrement {w dir big repeat} {\n"
|
5694 |
|
|
"global tkPriv\n"
|
5695 |
|
|
"if {![winfo exists $w]} return\n"
|
5696 |
|
|
"if {[string equal $big \"big\"]} {\n"
|
5697 |
|
|
"set inc [$w cget -bigincrement]\n"
|
5698 |
|
|
"if {$inc == 0} {\n"
|
5699 |
|
|
"set inc [expr {abs([$w cget -to] - [$w cget -from])/10.0}]\n"
|
5700 |
|
|
"}\n"
|
5701 |
|
|
"if {$inc < [$w cget -resolution]} {\n"
|
5702 |
|
|
"set inc [$w cget -resolution]\n"
|
5703 |
|
|
"}\n"
|
5704 |
|
|
"} else {\n"
|
5705 |
|
|
"set inc [$w cget -resolution]\n"
|
5706 |
|
|
"}\n"
|
5707 |
|
|
"if {([$w cget -from] > [$w cget -to]) ^ [string equal $dir \"up\"]} {\n"
|
5708 |
|
|
"set inc [expr {-$inc}]\n"
|
5709 |
|
|
"}\n"
|
5710 |
|
|
"$w set [expr {[$w get] + $inc}]\n"
|
5711 |
|
|
"if {[string equal $repeat \"again\"]} {\n"
|
5712 |
|
|
"set tkPriv(afterId) [after [$w cget -repeatinterval] \\\n"
|
5713 |
|
|
"\011\011[list tkScaleIncrement $w $dir $big again]]\n"
|
5714 |
|
|
"} elseif {[string equal $repeat \"initial\"]} {\n"
|
5715 |
|
|
"set delay [$w cget -repeatdelay]\n"
|
5716 |
|
|
"if {$delay > 0} {\n"
|
5717 |
|
|
"set tkPriv(afterId) [after $delay \\\n"
|
5718 |
|
|
"\011\011 [list tkScaleIncrement $w $dir $big again]]\n"
|
5719 |
|
|
"}\n"
|
5720 |
|
|
"}\n"
|
5721 |
|
|
"}\n"
|
5722 |
|
|
"proc tkScaleControlPress {w x y} {\n"
|
5723 |
|
|
"set el [$w identify $x $y]\n"
|
5724 |
|
|
"if {[string equal $el \"trough1\"]} {\n"
|
5725 |
|
|
"$w set [$w cget -from]\n"
|
5726 |
|
|
"} elseif {[string equal $el \"trough2\"]} {\n"
|
5727 |
|
|
"$w set [$w cget -to]\n"
|
5728 |
|
|
"}\n"
|
5729 |
|
|
"}\n"
|
5730 |
|
|
"proc tkScaleButton2Down {w x y} {\n"
|
5731 |
|
|
"global tkPriv\n"
|
5732 |
|
|
"if {[string equal [$w cget -state] \"disabled\"]} {\n"
|
5733 |
|
|
"return\n"
|
5734 |
|
|
"}\n"
|
5735 |
|
|
"$w configure -state active\n"
|
5736 |
|
|
"$w set [$w get $x $y]\n"
|
5737 |
|
|
"set tkPriv(dragging) 1\n"
|
5738 |
|
|
"set tkPriv(initValue) [$w get]\n"
|
5739 |
|
|
"set coords \"$x $y\"\n"
|
5740 |
|
|
"set tkPriv(deltaX) 0\n"
|
5741 |
|
|
"set tkPriv(deltaY) 0\n"
|
5742 |
|
|
"}\n"
|
5743 |
|
|
;
|
5744 |
|
|
static char Et_zFile24[] =
|
5745 |
|
|
"if {[string compare $tcl_platform(platform) \"windows\"] && \\\n"
|
5746 |
|
|
"\011[string compare $tcl_platform(platform) \"macintosh\"]} {\n"
|
5747 |
|
|
"bind Scrollbar <Enter> {\n"
|
5748 |
|
|
"if {$tk_strictMotif} {\n"
|
5749 |
|
|
"set tkPriv(activeBg) [%W cget -activebackground]\n"
|
5750 |
|
|
"%W config -activebackground [%W cget -background]\n"
|
5751 |
|
|
"}\n"
|
5752 |
|
|
"%W activate [%W identify %x %y]\n"
|
5753 |
|
|
"}\n"
|
5754 |
|
|
"bind Scrollbar <Motion> {\n"
|
5755 |
|
|
"%W activate [%W identify %x %y]\n"
|
5756 |
|
|
"}\n"
|
5757 |
|
|
"bind Scrollbar <Leave> {\n"
|
5758 |
|
|
"if {$tk_strictMotif && [info exists tkPriv(activeBg)]} {\n"
|
5759 |
|
|
"%W config -activebackground $tkPriv(activeBg)\n"
|
5760 |
|
|
"}\n"
|
5761 |
|
|
"%W activate {}\n"
|
5762 |
|
|
"}\n"
|
5763 |
|
|
"bind Scrollbar <1> {\n"
|
5764 |
|
|
"tkScrollButtonDown %W %x %y\n"
|
5765 |
|
|
"}\n"
|
5766 |
|
|
"bind Scrollbar <B1-Motion> {\n"
|
5767 |
|
|
"tkScrollDrag %W %x %y\n"
|
5768 |
|
|
"}\n"
|
5769 |
|
|
"bind Scrollbar <B1-B2-Motion> {\n"
|
5770 |
|
|
"tkScrollDrag %W %x %y\n"
|
5771 |
|
|
"}\n"
|
5772 |
|
|
"bind Scrollbar <ButtonRelease-1> {\n"
|
5773 |
|
|
"tkScrollButtonUp %W %x %y\n"
|
5774 |
|
|
"}\n"
|
5775 |
|
|
"bind Scrollbar <B1-Leave> {\n"
|
5776 |
|
|
"}\n"
|
5777 |
|
|
"bind Scrollbar <B1-Enter> {\n"
|
5778 |
|
|
"}\n"
|
5779 |
|
|
"bind Scrollbar <2> {\n"
|
5780 |
|
|
"tkScrollButton2Down %W %x %y\n"
|
5781 |
|
|
"}\n"
|
5782 |
|
|
"bind Scrollbar <B1-2> {\n"
|
5783 |
|
|
"}\n"
|
5784 |
|
|
"bind Scrollbar <B2-1> {\n"
|
5785 |
|
|
"}\n"
|
5786 |
|
|
"bind Scrollbar <B2-Motion> {\n"
|
5787 |
|
|
"tkScrollDrag %W %x %y\n"
|
5788 |
|
|
"}\n"
|
5789 |
|
|
"bind Scrollbar <ButtonRelease-2> {\n"
|
5790 |
|
|
"tkScrollButtonUp %W %x %y\n"
|
5791 |
|
|
"}\n"
|
5792 |
|
|
"bind Scrollbar <B1-ButtonRelease-2> {\n"
|
5793 |
|
|
"}\n"
|
5794 |
|
|
"bind Scrollbar <B2-ButtonRelease-1> {\n"
|
5795 |
|
|
"}\n"
|
5796 |
|
|
"bind Scrollbar <B2-Leave> {\n"
|
5797 |
|
|
"}\n"
|
5798 |
|
|
"bind Scrollbar <B2-Enter> {\n"
|
5799 |
|
|
"}\n"
|
5800 |
|
|
"bind Scrollbar <Control-1> {\n"
|
5801 |
|
|
"tkScrollTopBottom %W %x %y\n"
|
5802 |
|
|
"}\n"
|
5803 |
|
|
"bind Scrollbar <Control-2> {\n"
|
5804 |
|
|
"tkScrollTopBottom %W %x %y\n"
|
5805 |
|
|
"}\n"
|
5806 |
|
|
"bind Scrollbar <Up> {\n"
|
5807 |
|
|
"tkScrollByUnits %W v -1\n"
|
5808 |
|
|
"}\n"
|
5809 |
|
|
"bind Scrollbar <Down> {\n"
|
5810 |
|
|
"tkScrollByUnits %W v 1\n"
|
5811 |
|
|
"}\n"
|
5812 |
|
|
"bind Scrollbar <Control-Up> {\n"
|
5813 |
|
|
"tkScrollByPages %W v -1\n"
|
5814 |
|
|
"}\n"
|
5815 |
|
|
"bind Scrollbar <Control-Down> {\n"
|
5816 |
|
|
"tkScrollByPages %W v 1\n"
|
5817 |
|
|
"}\n"
|
5818 |
|
|
"bind Scrollbar <Left> {\n"
|
5819 |
|
|
"tkScrollByUnits %W h -1\n"
|
5820 |
|
|
"}\n"
|
5821 |
|
|
"bind Scrollbar <Right> {\n"
|
5822 |
|
|
"tkScrollByUnits %W h 1\n"
|
5823 |
|
|
"}\n"
|
5824 |
|
|
"bind Scrollbar <Control-Left> {\n"
|
5825 |
|
|
"tkScrollByPages %W h -1\n"
|
5826 |
|
|
"}\n"
|
5827 |
|
|
"bind Scrollbar <Control-Right> {\n"
|
5828 |
|
|
"tkScrollByPages %W h 1\n"
|
5829 |
|
|
"}\n"
|
5830 |
|
|
"bind Scrollbar <Prior> {\n"
|
5831 |
|
|
"tkScrollByPages %W hv -1\n"
|
5832 |
|
|
"}\n"
|
5833 |
|
|
"bind Scrollbar <Next> {\n"
|
5834 |
|
|
"tkScrollByPages %W hv 1\n"
|
5835 |
|
|
"}\n"
|
5836 |
|
|
"bind Scrollbar <Home> {\n"
|
5837 |
|
|
"tkScrollToPos %W 0\n"
|
5838 |
|
|
"}\n"
|
5839 |
|
|
"bind Scrollbar <End> {\n"
|
5840 |
|
|
"tkScrollToPos %W 1\n"
|
5841 |
|
|
"}\n"
|
5842 |
|
|
"}\n"
|
5843 |
|
|
"proc tkScrollButtonDown {w x y} {\n"
|
5844 |
|
|
"global tkPriv\n"
|
5845 |
|
|
"set tkPriv(relief) [$w cget -activerelief]\n"
|
5846 |
|
|
"$w configure -activerelief sunken\n"
|
5847 |
|
|
"set element [$w identify $x $y]\n"
|
5848 |
|
|
"if {[string equal $element \"slider\"]} {\n"
|
5849 |
|
|
"tkScrollStartDrag $w $x $y\n"
|
5850 |
|
|
"} else {\n"
|
5851 |
|
|
"tkScrollSelect $w $element initial\n"
|
5852 |
|
|
"}\n"
|
5853 |
|
|
"}\n"
|
5854 |
|
|
"proc tkScrollButtonUp {w x y} {\n"
|
5855 |
|
|
"global tkPriv\n"
|
5856 |
|
|
"tkCancelRepeat\n"
|
5857 |
|
|
"if {[info exists tkPriv(relief)]} {\n"
|
5858 |
|
|
"$w configure -activerelief $tkPriv(relief)\n"
|
5859 |
|
|
"tkScrollEndDrag $w $x $y\n"
|
5860 |
|
|
"$w activate [$w identify $x $y]\n"
|
5861 |
|
|
"}\n"
|
5862 |
|
|
"}\n"
|
5863 |
|
|
"proc tkScrollSelect {w element repeat} {\n"
|
5864 |
|
|
"global tkPriv\n"
|
5865 |
|
|
"if {![winfo exists $w]} return\n"
|
5866 |
|
|
"switch -- $element {\n"
|
5867 |
|
|
"\"arrow1\"\011{tkScrollByUnits $w hv -1}\n"
|
5868 |
|
|
"\"trough1\"\011{tkScrollByPages $w hv -1}\n"
|
5869 |
|
|
"\"trough2\"\011{tkScrollByPages $w hv 1}\n"
|
5870 |
|
|
"\"arrow2\"\011{tkScrollByUnits $w hv 1}\n"
|
5871 |
|
|
"default\011\011{return}\n"
|
5872 |
|
|
"}\n"
|
5873 |
|
|
"if {[string equal $repeat \"again\"]} {\n"
|
5874 |
|
|
"set tkPriv(afterId) [after [$w cget -repeatinterval] \\\n"
|
5875 |
|
|
"\011\011[list tkScrollSelect $w $element again]]\n"
|
5876 |
|
|
"} elseif {[string equal $repeat \"initial\"]} {\n"
|
5877 |
|
|
"set delay [$w cget -repeatdelay]\n"
|
5878 |
|
|
"if {$delay > 0} {\n"
|
5879 |
|
|
"set tkPriv(afterId) [after $delay \\\n"
|
5880 |
|
|
"\011\011 [list tkScrollSelect $w $element again]]\n"
|
5881 |
|
|
"}\n"
|
5882 |
|
|
"}\n"
|
5883 |
|
|
"}\n"
|
5884 |
|
|
"proc tkScrollStartDrag {w x y} {\n"
|
5885 |
|
|
"global tkPriv\n"
|
5886 |
|
|
"if {[string equal [$w cget -command] \"\"]} {\n"
|
5887 |
|
|
"return\n"
|
5888 |
|
|
"}\n"
|
5889 |
|
|
"set tkPriv(pressX) $x\n"
|
5890 |
|
|
"set tkPriv(pressY) $y\n"
|
5891 |
|
|
"set tkPriv(initValues) [$w get]\n"
|
5892 |
|
|
"set iv0 [lindex $tkPriv(initValues) 0]\n"
|
5893 |
|
|
"if {[llength $tkPriv(initValues)] == 2} {\n"
|
5894 |
|
|
"set tkPriv(initPos) $iv0\n"
|
5895 |
|
|
"} elseif {$iv0 == 0} {\n"
|
5896 |
|
|
"set tkPriv(initPos) 0.0\n"
|
5897 |
|
|
"} else {\n"
|
5898 |
|
|
"set tkPriv(initPos) [expr {(double([lindex $tkPriv(initValues) 2])) \\\n"
|
5899 |
|
|
"\011\011/ [lindex $tkPriv(initValues) 0]}]\n"
|
5900 |
|
|
"}\n"
|
5901 |
|
|
"}\n"
|
5902 |
|
|
"proc tkScrollDrag {w x y} {\n"
|
5903 |
|
|
"global tkPriv\n"
|
5904 |
|
|
"if {[string equal $tkPriv(initPos) \"\"]} {\n"
|
5905 |
|
|
"return\n"
|
5906 |
|
|
"}\n"
|
5907 |
|
|
"set delta [$w delta [expr {$x - $tkPriv(pressX)}] [expr {$y - $tkPriv(pressY)}]]\n"
|
5908 |
|
|
"if {[$w cget -jump]} {\n"
|
5909 |
|
|
"if {[llength $tkPriv(initValues)] == 2} {\n"
|
5910 |
|
|
"$w set [expr {[lindex $tkPriv(initValues) 0] + $delta}] \\\n"
|
5911 |
|
|
"\011\011 [expr {[lindex $tkPriv(initValues) 1] + $delta}]\n"
|
5912 |
|
|
"} else {\n"
|
5913 |
|
|
"set delta [expr {round($delta * [lindex $tkPriv(initValues) 0])}]\n"
|
5914 |
|
|
"eval [list $w] set [lreplace $tkPriv(initValues) 2 3 \\\n"
|
5915 |
|
|
"\011\011 [expr {[lindex $tkPriv(initValues) 2] + $delta}] \\\n"
|
5916 |
|
|
"\011\011 [expr {[lindex $tkPriv(initValues) 3] + $delta}]]\n"
|
5917 |
|
|
"}\n"
|
5918 |
|
|
"} else {\n"
|
5919 |
|
|
"tkScrollToPos $w [expr {$tkPriv(initPos) + $delta}]\n"
|
5920 |
|
|
"}\n"
|
5921 |
|
|
"}\n"
|
5922 |
|
|
"proc tkScrollEndDrag {w x y} {\n"
|
5923 |
|
|
"global tkPriv\n"
|
5924 |
|
|
"if {[string equal $tkPriv(initPos) \"\"]} {\n"
|
5925 |
|
|
"return\n"
|
5926 |
|
|
"}\n"
|
5927 |
|
|
"if {[$w cget -jump]} {\n"
|
5928 |
|
|
"set delta [$w delta [expr {$x - $tkPriv(pressX)}] \\\n"
|
5929 |
|
|
"\011\011[expr {$y - $tkPriv(pressY)}]]\n"
|
5930 |
|
|
"tkScrollToPos $w [expr {$tkPriv(initPos) + $delta}]\n"
|
5931 |
|
|
"}\n"
|
5932 |
|
|
"set tkPriv(initPos) \"\"\n"
|
5933 |
|
|
"}\n"
|
5934 |
|
|
"proc tkScrollByUnits {w orient amount} {\n"
|
5935 |
|
|
"set cmd [$w cget -command]\n"
|
5936 |
|
|
"if {[string equal $cmd \"\"] || ([string first \\\n"
|
5937 |
|
|
"\011 [string index [$w cget -orient] 0] $orient] < 0)} {\n"
|
5938 |
|
|
"return\n"
|
5939 |
|
|
"}\n"
|
5940 |
|
|
"set info [$w get]\n"
|
5941 |
|
|
"if {[llength $info] == 2} {\n"
|
5942 |
|
|
"uplevel #0 $cmd scroll $amount units\n"
|
5943 |
|
|
"} else {\n"
|
5944 |
|
|
"uplevel #0 $cmd [expr {[lindex $info 2] + $amount}]\n"
|
5945 |
|
|
"}\n"
|
5946 |
|
|
"}\n"
|
5947 |
|
|
"proc tkScrollByPages {w orient amount} {\n"
|
5948 |
|
|
"set cmd [$w cget -command]\n"
|
5949 |
|
|
"if {[string equal $cmd \"\"] || ([string first \\\n"
|
5950 |
|
|
"\011 [string index [$w cget -orient] 0] $orient] < 0)} {\n"
|
5951 |
|
|
"return\n"
|
5952 |
|
|
"}\n"
|
5953 |
|
|
"set info [$w get]\n"
|
5954 |
|
|
"if {[llength $info] == 2} {\n"
|
5955 |
|
|
"uplevel #0 $cmd scroll $amount pages\n"
|
5956 |
|
|
"} else {\n"
|
5957 |
|
|
"uplevel #0 $cmd [expr {[lindex $info 2] + $amount*([lindex $info 1] - 1)}]\n"
|
5958 |
|
|
"}\n"
|
5959 |
|
|
"}\n"
|
5960 |
|
|
"proc tkScrollToPos {w pos} {\n"
|
5961 |
|
|
"set cmd [$w cget -command]\n"
|
5962 |
|
|
"if {[string equal $cmd \"\"]} {\n"
|
5963 |
|
|
"return\n"
|
5964 |
|
|
"}\n"
|
5965 |
|
|
"set info [$w get]\n"
|
5966 |
|
|
"if {[llength $info] == 2} {\n"
|
5967 |
|
|
"uplevel #0 $cmd moveto $pos\n"
|
5968 |
|
|
"} else {\n"
|
5969 |
|
|
"uplevel #0 $cmd [expr {round([lindex $info 0]*$pos)}]\n"
|
5970 |
|
|
"}\n"
|
5971 |
|
|
"}\n"
|
5972 |
|
|
"proc tkScrollTopBottom {w x y} {\n"
|
5973 |
|
|
"global tkPriv\n"
|
5974 |
|
|
"set element [$w identify $x $y]\n"
|
5975 |
|
|
"if {[string match *1 $element]} {\n"
|
5976 |
|
|
"tkScrollToPos $w 0\n"
|
5977 |
|
|
"} elseif {[string match *2 $element]} {\n"
|
5978 |
|
|
"tkScrollToPos $w 1\n"
|
5979 |
|
|
"}\n"
|
5980 |
|
|
"set tkPriv(relief) [$w cget -activerelief]\n"
|
5981 |
|
|
"}\n"
|
5982 |
|
|
"proc tkScrollButton2Down {w x y} {\n"
|
5983 |
|
|
"global tkPriv\n"
|
5984 |
|
|
"set element [$w identify $x $y]\n"
|
5985 |
|
|
"if {[string match {arrow[12]} $element]} {\n"
|
5986 |
|
|
"tkScrollButtonDown $w $x $y\n"
|
5987 |
|
|
"return\n"
|
5988 |
|
|
"}\n"
|
5989 |
|
|
"tkScrollToPos $w [$w fraction $x $y]\n"
|
5990 |
|
|
"set tkPriv(relief) [$w cget -activerelief]\n"
|
5991 |
|
|
"update idletasks\n"
|
5992 |
|
|
"$w configure -activerelief sunken\n"
|
5993 |
|
|
"$w activate slider\n"
|
5994 |
|
|
"tkScrollStartDrag $w $x $y\n"
|
5995 |
|
|
"}\n"
|
5996 |
|
|
;
|
5997 |
|
|
static char Et_zFile25[] =
|
5998 |
|
|
"# Tcl autoload index file, version 2.0\n"
|
5999 |
|
|
"# This file is generated by the \"auto_mkindex\" command\n"
|
6000 |
|
|
"# and sourced to set up indexing information for one or\n"
|
6001 |
|
|
"# more commands. Typically each line is a command that\n"
|
6002 |
|
|
"# sets an element in the auto_index array, where the\n"
|
6003 |
|
|
"# element name is the name of a command and the value is\n"
|
6004 |
|
|
"# a script that loads the command.\n"
|
6005 |
|
|
"\n"
|
6006 |
|
|
"set auto_index(tkButtonEnter) [list source [file join $dir button.tcl]]\n"
|
6007 |
|
|
"set auto_index(tkButtonLeave) [list source [file join $dir button.tcl]]\n"
|
6008 |
|
|
"set auto_index(tkCheckRadioEnter) [list source [file join $dir button.tcl]]\n"
|
6009 |
|
|
"set auto_index(tkButtonDown) [list source [file join $dir button.tcl]]\n"
|
6010 |
|
|
"set auto_index(tkCheckRadioDown) [list source [file join $dir button.tcl]]\n"
|
6011 |
|
|
"set auto_index(tkButtonUp) [list source [file join $dir button.tcl]]\n"
|
6012 |
|
|
"set auto_index(tkButtonEnter) [list source [file join $dir button.tcl]]\n"
|
6013 |
|
|
"set auto_index(tkButtonLeave) [list source [file join $dir button.tcl]]\n"
|
6014 |
|
|
"set auto_index(tkButtonDown) [list source [file join $dir button.tcl]]\n"
|
6015 |
|
|
"set auto_index(tkButtonUp) [list source [file join $dir button.tcl]]\n"
|
6016 |
|
|
"set auto_index(tkButtonEnter) [list source [file join $dir button.tcl]]\n"
|
6017 |
|
|
"set auto_index(tkButtonLeave) [list source [file join $dir button.tcl]]\n"
|
6018 |
|
|
"set auto_index(tkButtonDown) [list source [file join $dir button.tcl]]\n"
|
6019 |
|
|
"set auto_index(tkButtonUp) [list source [file join $dir button.tcl]]\n"
|
6020 |
|
|
"set auto_index(tkButtonInvoke) [list source [file join $dir button.tcl]]\n"
|
6021 |
|
|
"set auto_index(tkCheckRadioInvoke) [list source [file join $dir button.tcl]]\n"
|
6022 |
|
|
"set auto_index(tk_dialog) [list source [file join $dir dialog.tcl]]\n"
|
6023 |
|
|
"set auto_index(tkEntryClosestGap) [list source [file join $dir entry.tcl]]\n"
|
6024 |
|
|
"set auto_index(tkEntryButton1) [list source [file join $dir entry.tcl]]\n"
|
6025 |
|
|
"set auto_index(tkEntryMouseSelect) [list source [file join $dir entry.tcl]]\n"
|
6026 |
|
|
"set auto_index(tkEntryPaste) [list source [file join $dir entry.tcl]]\n"
|
6027 |
|
|
"set auto_index(tkEntryAutoScan) [list source [file join $dir entry.tcl]]\n"
|
6028 |
|
|
"set auto_index(tkEntryKeySelect) [list source [file join $dir entry.tcl]]\n"
|
6029 |
|
|
"set auto_index(tkEntryInsert) [list source [file join $dir entry.tcl]]\n"
|
6030 |
|
|
"set auto_index(tkEntryBackspace) [list source [file join $dir entry.tcl]]\n"
|
6031 |
|
|
"set auto_index(tkEntrySeeInsert) [list source [file join $dir entry.tcl]]\n"
|
6032 |
|
|
"set auto_index(tkEntrySetCursor) [list source [file join $dir entry.tcl]]\n"
|
6033 |
|
|
"set auto_index(tkEntryTranspose) [list source [file join $dir entry.tcl]]\n"
|
6034 |
|
|
"set auto_index(tkEntryPreviousWord) [list source [file join $dir entry.tcl]]\n"
|
6035 |
|
|
"set auto_index(tkListboxBeginSelect) [list source [file join $dir listbox.tcl]]\n"
|
6036 |
|
|
"set auto_index(tkListboxMotion) [list source [file join $dir listbox.tcl]]\n"
|
6037 |
|
|
"set auto_index(tkListboxBeginExtend) [list source [file join $dir listbox.tcl]]\n"
|
6038 |
|
|
"set auto_index(tkListboxBeginToggle) [list source [file join $dir listbox.tcl]]\n"
|
6039 |
|
|
"set auto_index(tkListboxAutoScan) [list source [file join $dir listbox.tcl]]\n"
|
6040 |
|
|
"set auto_index(tkListboxUpDown) [list source [file join $dir listbox.tcl]]\n"
|
6041 |
|
|
"set auto_index(tkListboxExtendUpDown) [list source [file join $dir listbox.tcl]]\n"
|
6042 |
|
|
"set auto_index(tkListboxDataExtend) [list source [file join $dir listbox.tcl]]\n"
|
6043 |
|
|
"set auto_index(tkListboxCancel) [list source [file join $dir listbox.tcl]]\n"
|
6044 |
|
|
"set auto_index(tkListboxSelectAll) [list source [file join $dir listbox.tcl]]\n"
|
6045 |
|
|
"set auto_index(tkMbEnter) [list source [file join $dir menu.tcl]]\n"
|
6046 |
|
|
"set auto_index(tkMbLeave) [list source [file join $dir menu.tcl]]\n"
|
6047 |
|
|
"set auto_index(tkMbPost) [list source [file join $dir menu.tcl]]\n"
|
6048 |
|
|
"set auto_index(tkMenuUnpost) [list source [file join $dir menu.tcl]]\n"
|
6049 |
|
|
"set auto_index(tkMbMotion) [list source [file join $dir menu.tcl]]\n"
|
6050 |
|
|
"set auto_index(tkMbButtonUp) [list source [file join $dir menu.tcl]]\n"
|
6051 |
|
|
"set auto_index(tkMenuMotion) [list source [file join $dir menu.tcl]]\n"
|
6052 |
|
|
"set auto_index(tkMenuButtonDown) [list source [file join $dir menu.tcl]]\n"
|
6053 |
|
|
"set auto_index(tkMenuLeave) [list source [file join $dir menu.tcl]]\n"
|
6054 |
|
|
"set auto_index(tkMenuInvoke) [list source [file join $dir menu.tcl]]\n"
|
6055 |
|
|
"set auto_index(tkMenuEscape) [list source [file join $dir menu.tcl]]\n"
|
6056 |
|
|
"set auto_index(tkMenuUpArrow) [list source [file join $dir menu.tcl]]\n"
|
6057 |
|
|
"set auto_index(tkMenuDownArrow) [list source [file join $dir menu.tcl]]\n"
|
6058 |
|
|
"set auto_index(tkMenuLeftArrow) [list source [file join $dir menu.tcl]]\n"
|
6059 |
|
|
"set auto_index(tkMenuRightArrow) [list source [file join $dir menu.tcl]]\n"
|
6060 |
|
|
"set auto_index(tkMenuNextMenu) [list source [file join $dir menu.tcl]]\n"
|
6061 |
|
|
"set auto_index(tkMenuNextEntry) [list source [file join $dir menu.tcl]]\n"
|
6062 |
|
|
"set auto_index(tkMenuFind) [list source [file join $dir menu.tcl]]\n"
|
6063 |
|
|
"set auto_index(tkTraverseToMenu) [list source [file join $dir menu.tcl]]\n"
|
6064 |
|
|
"set auto_index(tkFirstMenu) [list source [file join $dir menu.tcl]]\n"
|
6065 |
|
|
"set auto_index(tkTraverseWithinMenu) [list source [file join $dir menu.tcl]]\n"
|
6066 |
|
|
"set auto_index(tkMenuFirstEntry) [list source [file join $dir menu.tcl]]\n"
|
6067 |
|
|
"set auto_index(tkMenuFindName) [list source [file join $dir menu.tcl]]\n"
|
6068 |
|
|
"set auto_index(tkPostOverPoint) [list source [file join $dir menu.tcl]]\n"
|
6069 |
|
|
"set auto_index(tkSaveGrabInfo) [list source [file join $dir menu.tcl]]\n"
|
6070 |
|
|
"set auto_index(tkRestoreOldGrab) [list source [file join $dir menu.tcl]]\n"
|
6071 |
|
|
"set auto_index(tk_menuSetFocus) [list source [file join $dir menu.tcl]]\n"
|
6072 |
|
|
"set auto_index(tkGenerateMenuSelect) [list source [file join $dir menu.tcl]]\n"
|
6073 |
|
|
"set auto_index(tk_popup) [list source [file join $dir menu.tcl]]\n"
|
6074 |
|
|
"set auto_index(tkScrollButtonDown) [list source [file join $dir scrlbar.tcl]]\n"
|
6075 |
|
|
"set auto_index(tkScrollButtonUp) [list source [file join $dir scrlbar.tcl]]\n"
|
6076 |
|
|
"set auto_index(tkScrollSelect) [list source [file join $dir scrlbar.tcl]]\n"
|
6077 |
|
|
"set auto_index(tkScrollStartDrag) [list source [file join $dir scrlbar.tcl]]\n"
|
6078 |
|
|
"set auto_index(tkScrollDrag) [list source [file join $dir scrlbar.tcl]]\n"
|
6079 |
|
|
"set auto_index(tkScrollEndDrag) [list source [file join $dir scrlbar.tcl]]\n"
|
6080 |
|
|
"set auto_index(tkScrollByUnits) [list source [file join $dir scrlbar.tcl]]\n"
|
6081 |
|
|
"set auto_index(tkScrollByPages) [list source [file join $dir scrlbar.tcl]]\n"
|
6082 |
|
|
"set auto_index(tkScrollToPos) [list source [file join $dir scrlbar.tcl]]\n"
|
6083 |
|
|
"set auto_index(tkScrollTopBottom) [list source [file join $dir scrlbar.tcl]]\n"
|
6084 |
|
|
"set auto_index(tkScrollButton2Down) [list source [file join $dir scrlbar.tcl]]\n"
|
6085 |
|
|
"set auto_index(tkTextClosestGap) [list source [file join $dir text.tcl]]\n"
|
6086 |
|
|
"set auto_index(tkTextButton1) [list source [file join $dir text.tcl]]\n"
|
6087 |
|
|
"set auto_index(tkTextSelectTo) [list source [file join $dir text.tcl]]\n"
|
6088 |
|
|
"set auto_index(tkTextKeyExtend) [list source [file join $dir text.tcl]]\n"
|
6089 |
|
|
"set auto_index(tkTextPaste) [list source [file join $dir text.tcl]]\n"
|
6090 |
|
|
"set auto_index(tkTextAutoScan) [list source [file join $dir text.tcl]]\n"
|
6091 |
|
|
"set auto_index(tkTextSetCursor) [list source [file join $dir text.tcl]]\n"
|
6092 |
|
|
"set auto_index(tkTextKeySelect) [list source [file join $dir text.tcl]]\n"
|
6093 |
|
|
"set auto_index(tkTextResetAnchor) [list source [file join $dir text.tcl]]\n"
|
6094 |
|
|
"set auto_index(tkTextInsert) [list source [file join $dir text.tcl]]\n"
|
6095 |
|
|
"set auto_index(tkTextUpDownLine) [list source [file join $dir text.tcl]]\n"
|
6096 |
|
|
"set auto_index(tkTextPrevPara) [list source [file join $dir text.tcl]]\n"
|
6097 |
|
|
"set auto_index(tkTextNextPara) [list source [file join $dir text.tcl]]\n"
|
6098 |
|
|
"set auto_index(tkTextScrollPages) [list source [file join $dir text.tcl]]\n"
|
6099 |
|
|
"set auto_index(tkTextTranspose) [list source [file join $dir text.tcl]]\n"
|
6100 |
|
|
"set auto_index(tk_textCopy) [list source [file join $dir text.tcl]]\n"
|
6101 |
|
|
"set auto_index(tk_textCut) [list source [file join $dir text.tcl]]\n"
|
6102 |
|
|
"set auto_index(tk_textPaste) [list source [file join $dir text.tcl]]\n"
|
6103 |
|
|
"set auto_index(tkTextNextPos) [list source [file join $dir text.tcl]]\n"
|
6104 |
|
|
"set auto_index(tkTextPrevPos) [list source [file join $dir text.tcl]]\n"
|
6105 |
|
|
"set auto_index(tkScreenChanged) [list source [file join $dir tk.tcl]]\n"
|
6106 |
|
|
"set auto_index(tkEventMotifBindings) [list source [file join $dir tk.tcl]]\n"
|
6107 |
|
|
"set auto_index(tkCancelRepeat) [list source [file join $dir tk.tcl]]\n"
|
6108 |
|
|
"set auto_index(tkTabToWindow) [list source [file join $dir tk.tcl]]\n"
|
6109 |
|
|
"set auto_index(bgerror) [list source [file join $dir bgerror.tcl]]\n"
|
6110 |
|
|
"set auto_index(tkScaleActivate) [list source [file join $dir scale.tcl]]\n"
|
6111 |
|
|
"set auto_index(tkScaleButtonDown) [list source [file join $dir scale.tcl]]\n"
|
6112 |
|
|
"set auto_index(tkScaleDrag) [list source [file join $dir scale.tcl]]\n"
|
6113 |
|
|
"set auto_index(tkScaleEndDrag) [list source [file join $dir scale.tcl]]\n"
|
6114 |
|
|
"set auto_index(tkScaleIncrement) [list source [file join $dir scale.tcl]]\n"
|
6115 |
|
|
"set auto_index(tkScaleControlPress) [list source [file join $dir scale.tcl]]\n"
|
6116 |
|
|
"set auto_index(tkScaleButton2Down) [list source [file join $dir scale.tcl]]\n"
|
6117 |
|
|
"set auto_index(tk_optionMenu) [list source [file join $dir optMenu.tcl]]\n"
|
6118 |
|
|
"set auto_index(tkTearOffMenu) [list source [file join $dir tearoff.tcl]]\n"
|
6119 |
|
|
"set auto_index(tkMenuDup) [list source [file join $dir tearoff.tcl]]\n"
|
6120 |
|
|
"set auto_index(tk_menuBar) [list source [file join $dir obsolete.tcl]]\n"
|
6121 |
|
|
"set auto_index(tk_bindForTraversal) [list source [file join $dir obsolete.tcl]]\n"
|
6122 |
|
|
"set auto_index(tk_focusNext) [list source [file join $dir focus.tcl]]\n"
|
6123 |
|
|
"set auto_index(tk_focusPrev) [list source [file join $dir focus.tcl]]\n"
|
6124 |
|
|
"set auto_index(tkFocusOK) [list source [file join $dir focus.tcl]]\n"
|
6125 |
|
|
"set auto_index(tk_focusFollowsMouse) [list source [file join $dir focus.tcl]]\n"
|
6126 |
|
|
"set auto_index(tkConsoleInit) [list source [file join $dir console.tcl]]\n"
|
6127 |
|
|
"set auto_index(tkConsoleSource) [list source [file join $dir console.tcl]]\n"
|
6128 |
|
|
"set auto_index(tkConsoleInvoke) [list source [file join $dir console.tcl]]\n"
|
6129 |
|
|
"set auto_index(tkConsoleHistory) [list source [file join $dir console.tcl]]\n"
|
6130 |
|
|
"set auto_index(tkConsolePrompt) [list source [file join $dir console.tcl]]\n"
|
6131 |
|
|
"set auto_index(tkConsoleBind) [list source [file join $dir console.tcl]]\n"
|
6132 |
|
|
"set auto_index(tkConsoleInsert) [list source [file join $dir console.tcl]]\n"
|
6133 |
|
|
"set auto_index(tkConsoleOutput) [list source [file join $dir console.tcl]]\n"
|
6134 |
|
|
"set auto_index(tkConsoleExit) [list source [file join $dir console.tcl]]\n"
|
6135 |
|
|
"set auto_index(tkConsoleAbout) [list source [file join $dir console.tcl]]\n"
|
6136 |
|
|
"set auto_index(tk_setPalette) [list source [file join $dir palette.tcl]]\n"
|
6137 |
|
|
"set auto_index(tkRecolorTree) [list source [file join $dir palette.tcl]]\n"
|
6138 |
|
|
"set auto_index(tkDarken) [list source [file join $dir palette.tcl]]\n"
|
6139 |
|
|
"set auto_index(tk_bisque) [list source [file join $dir palette.tcl]]\n"
|
6140 |
|
|
"set auto_index(tkColorDialog) [list source [file join $dir clrpick.tcl]]\n"
|
6141 |
|
|
"set auto_index(tkColorDialog_InitValues) [list source [file join $dir clrpick.tcl]]\n"
|
6142 |
|
|
"set auto_index(tkColorDialog_Config) [list source [file join $dir clrpick.tcl]]\n"
|
6143 |
|
|
"set auto_index(tkColorDialog_BuildDialog) [list source [file join $dir clrpick.tcl]]\n"
|
6144 |
|
|
"set auto_index(tkColorDialog_SetRGBValue) [list source [file join $dir clrpick.tcl]]\n"
|
6145 |
|
|
"set auto_index(tkColorDialog_XToRgb) [list source [file join $dir clrpick.tcl]]\n"
|
6146 |
|
|
"set auto_index(tkColorDialog_RgbToX) [list source [file join $dir clrpick.tcl]]\n"
|
6147 |
|
|
"set auto_index(tkColorDialog_DrawColorScale) [list source [file join $dir clrpick.tcl]]\n"
|
6148 |
|
|
"set auto_index(tkColorDialog_CreateSelector) [list source [file join $dir clrpick.tcl]]\n"
|
6149 |
|
|
"set auto_index(tkColorDialog_RedrawFinalColor) [list source [file join $dir clrpick.tcl]]\n"
|
6150 |
|
|
"set auto_index(tkColorDialog_RedrawColorBars) [list source [file join $dir clrpick.tcl]]\n"
|
6151 |
|
|
"set auto_index(tkColorDialog_StartMove) [list source [file join $dir clrpick.tcl]]\n"
|
6152 |
|
|
"set auto_index(tkColorDialog_MoveSelector) [list source [file join $dir clrpick.tcl]]\n"
|
6153 |
|
|
"set auto_index(tkColorDialog_ReleaseMouse) [list source [file join $dir clrpick.tcl]]\n"
|
6154 |
|
|
"set auto_index(tkColorDialog_ResizeColorBars) [list source [file join $dir clrpick.tcl]]\n"
|
6155 |
|
|
"set auto_index(tkColorDialog_HandleSelEntry) [list source [file join $dir clrpick.tcl]]\n"
|
6156 |
|
|
"set auto_index(tkColorDialog_HandleRGBEntry) [list source [file join $dir clrpick.tcl]]\n"
|
6157 |
|
|
"set auto_index(tkColorDialog_EnterColorBar) [list source [file join $dir clrpick.tcl]]\n"
|
6158 |
|
|
"set auto_index(tkColorDialog_LeaveColorBar) [list source [file join $dir clrpick.tcl]]\n"
|
6159 |
|
|
"set auto_index(tkColorDialog_OkCmd) [list source [file join $dir clrpick.tcl]]\n"
|
6160 |
|
|
"set auto_index(tkColorDialog_CancelCmd) [list source [file join $dir clrpick.tcl]]\n"
|
6161 |
|
|
"set auto_index(tclParseConfigSpec) [list source [file join $dir comdlg.tcl]]\n"
|
6162 |
|
|
"set auto_index(tclListValidFlags) [list source [file join $dir comdlg.tcl]]\n"
|
6163 |
|
|
"set auto_index(tclSortNoCase) [list source [file join $dir comdlg.tcl]]\n"
|
6164 |
|
|
"set auto_index(tclVerifyInteger) [list source [file join $dir comdlg.tcl]]\n"
|
6165 |
|
|
"set auto_index(tkFocusGroup_Create) [list source [file join $dir comdlg.tcl]]\n"
|
6166 |
|
|
"set auto_index(tkFocusGroup_BindIn) [list source [file join $dir comdlg.tcl]]\n"
|
6167 |
|
|
"set auto_index(tkFocusGroup_BindOut) [list source [file join $dir comdlg.tcl]]\n"
|
6168 |
|
|
"set auto_index(tkFocusGroup_Destroy) [list source [file join $dir comdlg.tcl]]\n"
|
6169 |
|
|
"set auto_index(tkFocusGroup_In) [list source [file join $dir comdlg.tcl]]\n"
|
6170 |
|
|
"set auto_index(tkFocusGroup_Out) [list source [file join $dir comdlg.tcl]]\n"
|
6171 |
|
|
"set auto_index(tkFDGetFileTypes) [list source [file join $dir comdlg.tcl]]\n"
|
6172 |
|
|
"set auto_index(::safe::loadTk) [list source [file join $dir safetk.tcl]]\n"
|
6173 |
|
|
"set auto_index(::safe::TkInit) [list source [file join $dir safetk.tcl]]\n"
|
6174 |
|
|
"set auto_index(::safe::allowTk) [list source [file join $dir safetk.tcl]]\n"
|
6175 |
|
|
"set auto_index(::safe::tkTopLevel) [list source [file join $dir safetk.tcl]]\n"
|
6176 |
|
|
"set auto_index(tkMessageBox) [list source [file join $dir msgbox.tcl]]\n"
|
6177 |
|
|
"set auto_index(tkIconList) [list source [file join $dir tkfbox.tcl]]\n"
|
6178 |
|
|
"set auto_index(tkIconList_Config) [list source [file join $dir tkfbox.tcl]]\n"
|
6179 |
|
|
"set auto_index(tkIconList_Create) [list source [file join $dir tkfbox.tcl]]\n"
|
6180 |
|
|
"set auto_index(tkIconList_AutoScan) [list source [file join $dir tkfbox.tcl]]\n"
|
6181 |
|
|
"set auto_index(tkIconList_DeleteAll) [list source [file join $dir tkfbox.tcl]]\n"
|
6182 |
|
|
"set auto_index(tkIconList_Add) [list source [file join $dir tkfbox.tcl]]\n"
|
6183 |
|
|
"set auto_index(tkIconList_Arrange) [list source [file join $dir tkfbox.tcl]]\n"
|
6184 |
|
|
"set auto_index(tkIconList_Invoke) [list source [file join $dir tkfbox.tcl]]\n"
|
6185 |
|
|
"set auto_index(tkIconList_See) [list source [file join $dir tkfbox.tcl]]\n"
|
6186 |
|
|
"set auto_index(tkIconList_SelectAtXY) [list source [file join $dir tkfbox.tcl]]\n"
|
6187 |
|
|
"set auto_index(tkIconList_Select) [list source [file join $dir tkfbox.tcl]]\n"
|
6188 |
|
|
"set auto_index(tkIconList_Unselect) [list source [file join $dir tkfbox.tcl]]\n"
|
6189 |
|
|
"set auto_index(tkIconList_Get) [list source [file join $dir tkfbox.tcl]]\n"
|
6190 |
|
|
"set auto_index(tkIconList_Btn1) [list source [file join $dir tkfbox.tcl]]\n"
|
6191 |
|
|
"set auto_index(tkIconList_Motion1) [list source [file join $dir tkfbox.tcl]]\n"
|
6192 |
|
|
"set auto_index(tkIconList_Double1) [list source [file join $dir tkfbox.tcl]]\n"
|
6193 |
|
|
"set auto_index(tkIconList_ReturnKey) [list source [file join $dir tkfbox.tcl]]\n"
|
6194 |
|
|
"set auto_index(tkIconList_Leave1) [list source [file join $dir tkfbox.tcl]]\n"
|
6195 |
|
|
"set auto_index(tkIconList_FocusIn) [list source [file join $dir tkfbox.tcl]]\n"
|
6196 |
|
|
"set auto_index(tkIconList_UpDown) [list source [file join $dir tkfbox.tcl]]\n"
|
6197 |
|
|
"set auto_index(tkIconList_LeftRight) [list source [file join $dir tkfbox.tcl]]\n"
|
6198 |
|
|
"set auto_index(tkIconList_KeyPress) [list source [file join $dir tkfbox.tcl]]\n"
|
6199 |
|
|
"set auto_index(tkIconList_Goto) [list source [file join $dir tkfbox.tcl]]\n"
|
6200 |
|
|
"set auto_index(tkIconList_Reset) [list source [file join $dir tkfbox.tcl]]\n"
|
6201 |
|
|
"set auto_index(::tk::dialog::file::tkFDialog) [list source [file join $dir tkfbox.tcl]]\n"
|
6202 |
|
|
"set auto_index(::tk::dialog::file::Config) [list source [file join $dir tkfbox.tcl]]\n"
|
6203 |
|
|
"set auto_index(::tk::dialog::file::Create) [list source [file join $dir tkfbox.tcl]]\n"
|
6204 |
|
|
"set auto_index(::tk::dialog::file::UpdateWhenIdle) [list source [file join $dir tkfbox.tcl]]\n"
|
6205 |
|
|
"set auto_index(::tk::dialog::file::Update) [list source [file join $dir tkfbox.tcl]]\n"
|
6206 |
|
|
"set auto_index(::tk::dialog::file::SetPathSilently) [list source [file join $dir tkfbox.tcl]]\n"
|
6207 |
|
|
"set auto_index(::tk::dialog::file::SetPath) [list source [file join $dir tkfbox.tcl]]\n"
|
6208 |
|
|
"set auto_index(::tk::dialog::file::SetFilter) [list source [file join $dir tkfbox.tcl]]\n"
|
6209 |
|
|
"set auto_index(tkFDialogResolveFile) [list source [file join $dir tkfbox.tcl]]\n"
|
6210 |
|
|
"set auto_index(::tk::dialog::file::EntFocusIn) [list source [file join $dir tkfbox.tcl]]\n"
|
6211 |
|
|
"set auto_index(::tk::dialog::file::EntFocusOut) [list source [file join $dir tkfbox.tcl]]\n"
|
6212 |
|
|
"set auto_index(::tk::dialog::file::ActivateEnt) [list source [file join $dir tkfbox.tcl]]\n"
|
6213 |
|
|
"set auto_index(::tk::dialog::file::InvokeBtn) [list source [file join $dir tkfbox.tcl]]\n"
|
6214 |
|
|
"set auto_index(::tk::dialog::file::UpDirCmd) [list source [file join $dir tkfbox.tcl]]\n"
|
6215 |
|
|
"set auto_index(::tk::dialog::file::JoinFile) [list source [file join $dir tkfbox.tcl]]\n"
|
6216 |
|
|
"set auto_index(::tk::dialog::file::OkCmd) [list source [file join $dir tkfbox.tcl]]\n"
|
6217 |
|
|
"set auto_index(::tk::dialog::file::CancelCmd) [list source [file join $dir tkfbox.tcl]]\n"
|
6218 |
|
|
"set auto_index(::tk::dialog::file::ListBrowse) [list source [file join $dir tkfbox.tcl]]\n"
|
6219 |
|
|
"set auto_index(::tk::dialog::file::ListInvoke) [list source [file join $dir tkfbox.tcl]]\n"
|
6220 |
|
|
"set auto_index(::tk::dialog::file::Done) [list source [file join $dir tkfbox.tcl]]\n"
|
6221 |
|
|
"set auto_index(tkMotifFDialog) [list source [file join $dir xmfbox.tcl]]\n"
|
6222 |
|
|
"set auto_index(tkMotifFDialog_Config) [list source [file join $dir xmfbox.tcl]]\n"
|
6223 |
|
|
"set auto_index(tkMotifFDialog_Create) [list source [file join $dir xmfbox.tcl]]\n"
|
6224 |
|
|
"set auto_index(tkMotifFDialog_MakeSList) [list source [file join $dir xmfbox.tcl]]\n"
|
6225 |
|
|
"set auto_index(tkMotifFDialog_BrowseDList) [list source [file join $dir xmfbox.tcl]]\n"
|
6226 |
|
|
"set auto_index(tkMotifFDialog_ActivateDList) [list source [file join $dir xmfbox.tcl]]\n"
|
6227 |
|
|
"set auto_index(tkMotifFDialog_BrowseFList) [list source [file join $dir xmfbox.tcl]]\n"
|
6228 |
|
|
"set auto_index(tkMotifFDialog_ActivateFList) [list source [file join $dir xmfbox.tcl]]\n"
|
6229 |
|
|
"set auto_index(tkMotifFDialog_ActivateFEnt) [list source [file join $dir xmfbox.tcl]]\n"
|
6230 |
|
|
"set auto_index(tkMotifFDialog_InterpFilter) [list source [file join $dir xmfbox.tcl]]\n"
|
6231 |
|
|
"set auto_index(tkMotifFDialog_ActivateSEnt) [list source [file join $dir xmfbox.tcl]]\n"
|
6232 |
|
|
"set auto_index(tkMotifFDialog_OkCmd) [list source [file join $dir xmfbox.tcl]]\n"
|
6233 |
|
|
"set auto_index(tkMotifFDialog_FilterCmd) [list source [file join $dir xmfbox.tcl]]\n"
|
6234 |
|
|
"set auto_index(tkMotifFDialog_CancelCmd) [list source [file join $dir xmfbox.tcl]]\n"
|
6235 |
|
|
"set auto_index(tkMotifFDialog_Update) [list source [file join $dir xmfbox.tcl]]\n"
|
6236 |
|
|
"set auto_index(tkMotifFDialog_LoadFiles) [list source [file join $dir xmfbox.tcl]]\n"
|
6237 |
|
|
"set auto_index(tkListBoxKeyAccel_Set) [list source [file join $dir xmfbox.tcl]]\n"
|
6238 |
|
|
"set auto_index(tkListBoxKeyAccel_Unset) [list source [file join $dir xmfbox.tcl]]\n"
|
6239 |
|
|
"set auto_index(tkListBoxKeyAccel_Key) [list source [file join $dir xmfbox.tcl]]\n"
|
6240 |
|
|
"set auto_index(tkListBoxKeyAccel_Goto) [list source [file join $dir xmfbox.tcl]]\n"
|
6241 |
|
|
"set auto_index(tkListBoxKeyAccel_Reset) [list source [file join $dir xmfbox.tcl]]\n"
|
6242 |
|
|
"set auto_index(::tk::dialog::file::chooseDir::tkChooseDirectory) [list source [file join $dir choosedir.tcl]]\n"
|
6243 |
|
|
;
|
6244 |
|
|
static char Et_zFile26[] =
|
6245 |
|
|
"proc tkTearOffMenu {w {x 0} {y 0}} {\n"
|
6246 |
|
|
"if {$x == 0} {\n"
|
6247 |
|
|
"set x [winfo rootx $w]\n"
|
6248 |
|
|
"}\n"
|
6249 |
|
|
"if {$y == 0} {\n"
|
6250 |
|
|
"set y [winfo rooty $w]\n"
|
6251 |
|
|
"}\n"
|
6252 |
|
|
"set parent [winfo parent $w]\n"
|
6253 |
|
|
"while {[string compare [winfo toplevel $parent] $parent] \\\n"
|
6254 |
|
|
"\011 || [string equal [winfo class $parent] \"Menu\"]} {\n"
|
6255 |
|
|
"set parent [winfo parent $parent]\n"
|
6256 |
|
|
"}\n"
|
6257 |
|
|
"if {[string equal $parent \".\"]} {\n"
|
6258 |
|
|
"set parent \"\"\n"
|
6259 |
|
|
"}\n"
|
6260 |
|
|
"for {set i 1} 1 {incr i} {\n"
|
6261 |
|
|
"set menu $parent.tearoff$i\n"
|
6262 |
|
|
"if {![winfo exists $menu]} {\n"
|
6263 |
|
|
"break\n"
|
6264 |
|
|
"}\n"
|
6265 |
|
|
"}\n"
|
6266 |
|
|
"$w clone $menu tearoff\n"
|
6267 |
|
|
"set parent [winfo parent $w]\n"
|
6268 |
|
|
"if {[string compare [$menu cget -title] \"\"]} {\n"
|
6269 |
|
|
"wm title $menu [$menu cget -title]\n"
|
6270 |
|
|
"} else {\n"
|
6271 |
|
|
"switch [winfo class $parent] {\n"
|
6272 |
|
|
"Menubutton {\n"
|
6273 |
|
|
"wm title $menu [$parent cget -text]\n"
|
6274 |
|
|
"}\n"
|
6275 |
|
|
"Menu {\n"
|
6276 |
|
|
"wm title $menu [$parent entrycget active -label]\n"
|
6277 |
|
|
"}\n"
|
6278 |
|
|
"}\n"
|
6279 |
|
|
"}\n"
|
6280 |
|
|
"$menu post $x $y\n"
|
6281 |
|
|
"if {[winfo exists $menu] == 0} {\n"
|
6282 |
|
|
"return \"\"\n"
|
6283 |
|
|
"}\n"
|
6284 |
|
|
"bind $menu <Enter> {\n"
|
6285 |
|
|
"set tkPriv(focus) %W\n"
|
6286 |
|
|
"}\n"
|
6287 |
|
|
"set cmd [$w cget -tearoffcommand]\n"
|
6288 |
|
|
"if {[string compare $cmd \"\"]} {\n"
|
6289 |
|
|
"uplevel #0 $cmd [list $w $menu]\n"
|
6290 |
|
|
"}\n"
|
6291 |
|
|
"return $menu\n"
|
6292 |
|
|
"}\n"
|
6293 |
|
|
"proc tkMenuDup {src dst type} {\n"
|
6294 |
|
|
"set cmd [list menu $dst -type $type]\n"
|
6295 |
|
|
"foreach option [$src configure] {\n"
|
6296 |
|
|
"if {[llength $option] == 2} {\n"
|
6297 |
|
|
"continue\n"
|
6298 |
|
|
"}\n"
|
6299 |
|
|
"if {[string equal [lindex $option 0] \"-type\"]} {\n"
|
6300 |
|
|
"continue\n"
|
6301 |
|
|
"}\n"
|
6302 |
|
|
"lappend cmd [lindex $option 0] [lindex $option 4]\n"
|
6303 |
|
|
"}\n"
|
6304 |
|
|
"eval $cmd\n"
|
6305 |
|
|
"set last [$src index last]\n"
|
6306 |
|
|
"if {[string equal $last \"none\"]} {\n"
|
6307 |
|
|
"return\n"
|
6308 |
|
|
"}\n"
|
6309 |
|
|
"for {set i [$src cget -tearoff]} {$i <= $last} {incr i} {\n"
|
6310 |
|
|
"set cmd [list $dst add [$src type $i]]\n"
|
6311 |
|
|
"foreach option [$src entryconfigure $i] {\n"
|
6312 |
|
|
"lappend cmd [lindex $option 0] [lindex $option 4]\n"
|
6313 |
|
|
"}\n"
|
6314 |
|
|
"eval $cmd\n"
|
6315 |
|
|
"}\n"
|
6316 |
|
|
"set tags [bindtags $src]\n"
|
6317 |
|
|
"set srcLen [string length $src]\n"
|
6318 |
|
|
"while {[set index [string first $src $tags]] != -1} {\n"
|
6319 |
|
|
"append x [string range $tags 0 [expr {$index - 1}]]$dst\n"
|
6320 |
|
|
"set tags [string range $tags [expr {$index + $srcLen}] end]\n"
|
6321 |
|
|
"}\n"
|
6322 |
|
|
"append x $tags\n"
|
6323 |
|
|
"bindtags $dst $x\n"
|
6324 |
|
|
"foreach event [bind $src] {\n"
|
6325 |
|
|
"unset x\n"
|
6326 |
|
|
"set script [bind $src $event]\n"
|
6327 |
|
|
"set eventLen [string length $event]\n"
|
6328 |
|
|
"while {[set index [string first $event $script]] != -1} {\n"
|
6329 |
|
|
"append x [string range $script 0 [expr {$index - 1}]]\n"
|
6330 |
|
|
"append x $dst\n"
|
6331 |
|
|
"set script [string range $script [expr {$index + $eventLen}] end]\n"
|
6332 |
|
|
"}\n"
|
6333 |
|
|
"append x $script\n"
|
6334 |
|
|
"bind $dst $event $x\n"
|
6335 |
|
|
"}\n"
|
6336 |
|
|
"}\n"
|
6337 |
|
|
;
|
6338 |
|
|
static char Et_zFile27[] =
|
6339 |
|
|
"bind Text <1> {\n"
|
6340 |
|
|
"tkTextButton1 %W %x %y\n"
|
6341 |
|
|
"%W tag remove sel 0.0 end\n"
|
6342 |
|
|
"}\n"
|
6343 |
|
|
"bind Text <B1-Motion> {\n"
|
6344 |
|
|
"set tkPriv(x) %x\n"
|
6345 |
|
|
"set tkPriv(y) %y\n"
|
6346 |
|
|
"tkTextSelectTo %W %x %y\n"
|
6347 |
|
|
"}\n"
|
6348 |
|
|
"bind Text <Double-1> {\n"
|
6349 |
|
|
"set tkPriv(selectMode) word\n"
|
6350 |
|
|
"tkTextSelectTo %W %x %y\n"
|
6351 |
|
|
"catch {%W mark set insert sel.last}\n"
|
6352 |
|
|
"catch {%W mark set anchor sel.first}\n"
|
6353 |
|
|
"}\n"
|
6354 |
|
|
"bind Text <Triple-1> {\n"
|
6355 |
|
|
"set tkPriv(selectMode) line\n"
|
6356 |
|
|
"tkTextSelectTo %W %x %y\n"
|
6357 |
|
|
"catch {%W mark set insert sel.last}\n"
|
6358 |
|
|
"catch {%W mark set anchor sel.first}\n"
|
6359 |
|
|
"}\n"
|
6360 |
|
|
"bind Text <Shift-1> {\n"
|
6361 |
|
|
"tkTextResetAnchor %W @%x,%y\n"
|
6362 |
|
|
"set tkPriv(selectMode) char\n"
|
6363 |
|
|
"tkTextSelectTo %W %x %y\n"
|
6364 |
|
|
"}\n"
|
6365 |
|
|
"bind Text <Double-Shift-1>\011{\n"
|
6366 |
|
|
"set tkPriv(selectMode) word\n"
|
6367 |
|
|
"tkTextSelectTo %W %x %y 1\n"
|
6368 |
|
|
"}\n"
|
6369 |
|
|
"bind Text <Triple-Shift-1>\011{\n"
|
6370 |
|
|
"set tkPriv(selectMode) line\n"
|
6371 |
|
|
"tkTextSelectTo %W %x %y\n"
|
6372 |
|
|
"}\n"
|
6373 |
|
|
"bind Text <B1-Leave> {\n"
|
6374 |
|
|
"set tkPriv(x) %x\n"
|
6375 |
|
|
"set tkPriv(y) %y\n"
|
6376 |
|
|
"tkTextAutoScan %W\n"
|
6377 |
|
|
"}\n"
|
6378 |
|
|
"bind Text <B1-Enter> {\n"
|
6379 |
|
|
"tkCancelRepeat\n"
|
6380 |
|
|
"}\n"
|
6381 |
|
|
"bind Text <ButtonRelease-1> {\n"
|
6382 |
|
|
"tkCancelRepeat\n"
|
6383 |
|
|
"}\n"
|
6384 |
|
|
"bind Text <Control-1> {\n"
|
6385 |
|
|
"%W mark set insert @%x,%y\n"
|
6386 |
|
|
"}\n"
|
6387 |
|
|
"bind Text <Left> {\n"
|
6388 |
|
|
"tkTextSetCursor %W insert-1c\n"
|
6389 |
|
|
"}\n"
|
6390 |
|
|
"bind Text <Right> {\n"
|
6391 |
|
|
"tkTextSetCursor %W insert+1c\n"
|
6392 |
|
|
"}\n"
|
6393 |
|
|
"bind Text <Up> {\n"
|
6394 |
|
|
"tkTextSetCursor %W [tkTextUpDownLine %W -1]\n"
|
6395 |
|
|
"}\n"
|
6396 |
|
|
"bind Text <Down> {\n"
|
6397 |
|
|
"tkTextSetCursor %W [tkTextUpDownLine %W 1]\n"
|
6398 |
|
|
"}\n"
|
6399 |
|
|
"bind Text <Shift-Left> {\n"
|
6400 |
|
|
"tkTextKeySelect %W [%W index {insert - 1c}]\n"
|
6401 |
|
|
"}\n"
|
6402 |
|
|
"bind Text <Shift-Right> {\n"
|
6403 |
|
|
"tkTextKeySelect %W [%W index {insert + 1c}]\n"
|
6404 |
|
|
"}\n"
|
6405 |
|
|
"bind Text <Shift-Up> {\n"
|
6406 |
|
|
"tkTextKeySelect %W [tkTextUpDownLine %W -1]\n"
|
6407 |
|
|
"}\n"
|
6408 |
|
|
"bind Text <Shift-Down> {\n"
|
6409 |
|
|
"tkTextKeySelect %W [tkTextUpDownLine %W 1]\n"
|
6410 |
|
|
"}\n"
|
6411 |
|
|
"bind Text <Control-Left> {\n"
|
6412 |
|
|
"tkTextSetCursor %W [tkTextPrevPos %W insert tcl_startOfPreviousWord]\n"
|
6413 |
|
|
"}\n"
|
6414 |
|
|
"bind Text <Control-Right> {\n"
|
6415 |
|
|
"tkTextSetCursor %W [tkTextNextWord %W insert]\n"
|
6416 |
|
|
"}\n"
|
6417 |
|
|
"bind Text <Control-Up> {\n"
|
6418 |
|
|
"tkTextSetCursor %W [tkTextPrevPara %W insert]\n"
|
6419 |
|
|
"}\n"
|
6420 |
|
|
"bind Text <Control-Down> {\n"
|
6421 |
|
|
"tkTextSetCursor %W [tkTextNextPara %W insert]\n"
|
6422 |
|
|
"}\n"
|
6423 |
|
|
"bind Text <Shift-Control-Left> {\n"
|
6424 |
|
|
"tkTextKeySelect %W [tkTextPrevPos %W insert tcl_startOfPreviousWord]\n"
|
6425 |
|
|
"}\n"
|
6426 |
|
|
"bind Text <Shift-Control-Right> {\n"
|
6427 |
|
|
"tkTextKeySelect %W [tkTextNextWord %W insert]\n"
|
6428 |
|
|
"}\n"
|
6429 |
|
|
"bind Text <Shift-Control-Up> {\n"
|
6430 |
|
|
"tkTextKeySelect %W [tkTextPrevPara %W insert]\n"
|
6431 |
|
|
"}\n"
|
6432 |
|
|
"bind Text <Shift-Control-Down> {\n"
|
6433 |
|
|
"tkTextKeySelect %W [tkTextNextPara %W insert]\n"
|
6434 |
|
|
"}\n"
|
6435 |
|
|
"bind Text <Prior> {\n"
|
6436 |
|
|
"tkTextSetCursor %W [tkTextScrollPages %W -1]\n"
|
6437 |
|
|
"}\n"
|
6438 |
|
|
"bind Text <Shift-Prior> {\n"
|
6439 |
|
|
"tkTextKeySelect %W [tkTextScrollPages %W -1]\n"
|
6440 |
|
|
"}\n"
|
6441 |
|
|
"bind Text <Next> {\n"
|
6442 |
|
|
"tkTextSetCursor %W [tkTextScrollPages %W 1]\n"
|
6443 |
|
|
"}\n"
|
6444 |
|
|
"bind Text <Shift-Next> {\n"
|
6445 |
|
|
"tkTextKeySelect %W [tkTextScrollPages %W 1]\n"
|
6446 |
|
|
"}\n"
|
6447 |
|
|
"bind Text <Control-Prior> {\n"
|
6448 |
|
|
"%W xview scroll -1 page\n"
|
6449 |
|
|
"}\n"
|
6450 |
|
|
"bind Text <Control-Next> {\n"
|
6451 |
|
|
"%W xview scroll 1 page\n"
|
6452 |
|
|
"}\n"
|
6453 |
|
|
"bind Text <Home> {\n"
|
6454 |
|
|
"tkTextSetCursor %W {insert linestart}\n"
|
6455 |
|
|
"}\n"
|
6456 |
|
|
"bind Text <Shift-Home> {\n"
|
6457 |
|
|
"tkTextKeySelect %W {insert linestart}\n"
|
6458 |
|
|
"}\n"
|
6459 |
|
|
"bind Text <End> {\n"
|
6460 |
|
|
"tkTextSetCursor %W {insert lineend}\n"
|
6461 |
|
|
"}\n"
|
6462 |
|
|
"bind Text <Shift-End> {\n"
|
6463 |
|
|
"tkTextKeySelect %W {insert lineend}\n"
|
6464 |
|
|
"}\n"
|
6465 |
|
|
"bind Text <Control-Home> {\n"
|
6466 |
|
|
"tkTextSetCursor %W 1.0\n"
|
6467 |
|
|
"}\n"
|
6468 |
|
|
"bind Text <Control-Shift-Home> {\n"
|
6469 |
|
|
"tkTextKeySelect %W 1.0\n"
|
6470 |
|
|
"}\n"
|
6471 |
|
|
"bind Text <Control-End> {\n"
|
6472 |
|
|
"tkTextSetCursor %W {end - 1 char}\n"
|
6473 |
|
|
"}\n"
|
6474 |
|
|
"bind Text <Control-Shift-End> {\n"
|
6475 |
|
|
"tkTextKeySelect %W {end - 1 char}\n"
|
6476 |
|
|
"}\n"
|
6477 |
|
|
"bind Text <Tab> {\n"
|
6478 |
|
|
"tkTextInsert %W \\t\n"
|
6479 |
|
|
"focus %W\n"
|
6480 |
|
|
"break\n"
|
6481 |
|
|
"}\n"
|
6482 |
|
|
"bind Text <Shift-Tab> {\n"
|
6483 |
|
|
"break\n"
|
6484 |
|
|
"}\n"
|
6485 |
|
|
"bind Text <Control-Tab> {\n"
|
6486 |
|
|
"focus [tk_focusNext %W]\n"
|
6487 |
|
|
"}\n"
|
6488 |
|
|
"bind Text <Control-Shift-Tab> {\n"
|
6489 |
|
|
"focus [tk_focusPrev %W]\n"
|
6490 |
|
|
"}\n"
|
6491 |
|
|
"bind Text <Control-i> {\n"
|
6492 |
|
|
"tkTextInsert %W \\t\n"
|
6493 |
|
|
"}\n"
|
6494 |
|
|
"bind Text <Return> {\n"
|
6495 |
|
|
"tkTextInsert %W \\n\n"
|
6496 |
|
|
"}\n"
|
6497 |
|
|
"bind Text <Delete> {\n"
|
6498 |
|
|
"if {[string compare [%W tag nextrange sel 1.0 end] \"\"]} {\n"
|
6499 |
|
|
"%W delete sel.first sel.last\n"
|
6500 |
|
|
"} else {\n"
|
6501 |
|
|
"%W delete insert\n"
|
6502 |
|
|
"%W see insert\n"
|
6503 |
|
|
"}\n"
|
6504 |
|
|
"}\n"
|
6505 |
|
|
"bind Text <BackSpace> {\n"
|
6506 |
|
|
"if {[string compare [%W tag nextrange sel 1.0 end] \"\"]} {\n"
|
6507 |
|
|
"%W delete sel.first sel.last\n"
|
6508 |
|
|
"} elseif {[%W compare insert != 1.0]} {\n"
|
6509 |
|
|
"%W delete insert-1c\n"
|
6510 |
|
|
"%W see insert\n"
|
6511 |
|
|
"}\n"
|
6512 |
|
|
"}\n"
|
6513 |
|
|
"bind Text <Control-space> {\n"
|
6514 |
|
|
"%W mark set anchor insert\n"
|
6515 |
|
|
"}\n"
|
6516 |
|
|
"bind Text <Select> {\n"
|
6517 |
|
|
"%W mark set anchor insert\n"
|
6518 |
|
|
"}\n"
|
6519 |
|
|
"bind Text <Control-Shift-space> {\n"
|
6520 |
|
|
"set tkPriv(selectMode) char\n"
|
6521 |
|
|
"tkTextKeyExtend %W insert\n"
|
6522 |
|
|
"}\n"
|
6523 |
|
|
"bind Text <Shift-Select> {\n"
|
6524 |
|
|
"set tkPriv(selectMode) char\n"
|
6525 |
|
|
"tkTextKeyExtend %W insert\n"
|
6526 |
|
|
"}\n"
|
6527 |
|
|
"bind Text <Control-slash> {\n"
|
6528 |
|
|
"%W tag add sel 1.0 end\n"
|
6529 |
|
|
"}\n"
|
6530 |
|
|
"bind Text <Control-backslash> {\n"
|
6531 |
|
|
"%W tag remove sel 1.0 end\n"
|
6532 |
|
|
"}\n"
|
6533 |
|
|
"bind Text <<Cut>> {\n"
|
6534 |
|
|
"tk_textCut %W\n"
|
6535 |
|
|
"}\n"
|
6536 |
|
|
"bind Text <<Copy>> {\n"
|
6537 |
|
|
"tk_textCopy %W\n"
|
6538 |
|
|
"}\n"
|
6539 |
|
|
"bind Text <<Paste>> {\n"
|
6540 |
|
|
"tk_textPaste %W\n"
|
6541 |
|
|
"}\n"
|
6542 |
|
|
"bind Text <<Clear>> {\n"
|
6543 |
|
|
"catch {%W delete sel.first sel.last}\n"
|
6544 |
|
|
"}\n"
|
6545 |
|
|
"bind Text <<PasteSelection>> {\n"
|
6546 |
|
|
"if {!$tkPriv(mouseMoved) || $tk_strictMotif} {\n"
|
6547 |
|
|
"tkTextPaste %W %x %y\n"
|
6548 |
|
|
"}\n"
|
6549 |
|
|
"}\n"
|
6550 |
|
|
"bind Text <Insert> {\n"
|
6551 |
|
|
"catch {tkTextInsert %W [selection get -displayof %W]}\n"
|
6552 |
|
|
"}\n"
|
6553 |
|
|
"bind Text <KeyPress> {\n"
|
6554 |
|
|
"tkTextInsert %W %A\n"
|
6555 |
|
|
"}\n"
|
6556 |
|
|
"bind Text <Alt-KeyPress> {# nothing }\n"
|
6557 |
|
|
"bind Text <Meta-KeyPress> {# nothing}\n"
|
6558 |
|
|
"bind Text <Control-KeyPress> {# nothing}\n"
|
6559 |
|
|
"bind Text <Escape> {# nothing}\n"
|
6560 |
|
|
"bind Text <KP_Enter> {# nothing}\n"
|
6561 |
|
|
"if {[string equal $tcl_platform(platform) \"macintosh\"]} {\n"
|
6562 |
|
|
"bind Text <Command-KeyPress> {# nothing}\n"
|
6563 |
|
|
"}\n"
|
6564 |
|
|
"bind Text <Control-a> {\n"
|
6565 |
|
|
"if {!$tk_strictMotif} {\n"
|
6566 |
|
|
"tkTextSetCursor %W {insert linestart}\n"
|
6567 |
|
|
"}\n"
|
6568 |
|
|
"}\n"
|
6569 |
|
|
"bind Text <Control-b> {\n"
|
6570 |
|
|
"if {!$tk_strictMotif} {\n"
|
6571 |
|
|
"tkTextSetCursor %W insert-1c\n"
|
6572 |
|
|
"}\n"
|
6573 |
|
|
"}\n"
|
6574 |
|
|
"bind Text <Control-d> {\n"
|
6575 |
|
|
"if {!$tk_strictMotif} {\n"
|
6576 |
|
|
"%W delete insert\n"
|
6577 |
|
|
"}\n"
|
6578 |
|
|
"}\n"
|
6579 |
|
|
"bind Text <Control-e> {\n"
|
6580 |
|
|
"if {!$tk_strictMotif} {\n"
|
6581 |
|
|
"tkTextSetCursor %W {insert lineend}\n"
|
6582 |
|
|
"}\n"
|
6583 |
|
|
"}\n"
|
6584 |
|
|
"bind Text <Control-f> {\n"
|
6585 |
|
|
"if {!$tk_strictMotif} {\n"
|
6586 |
|
|
"tkTextSetCursor %W insert+1c\n"
|
6587 |
|
|
"}\n"
|
6588 |
|
|
"}\n"
|
6589 |
|
|
"bind Text <Control-k> {\n"
|
6590 |
|
|
"if {!$tk_strictMotif} {\n"
|
6591 |
|
|
"if {[%W compare insert == {insert lineend}]} {\n"
|
6592 |
|
|
"%W delete insert\n"
|
6593 |
|
|
"} else {\n"
|
6594 |
|
|
"%W delete insert {insert lineend}\n"
|
6595 |
|
|
"}\n"
|
6596 |
|
|
"}\n"
|
6597 |
|
|
"}\n"
|
6598 |
|
|
"bind Text <Control-n> {\n"
|
6599 |
|
|
"if {!$tk_strictMotif} {\n"
|
6600 |
|
|
"tkTextSetCursor %W [tkTextUpDownLine %W 1]\n"
|
6601 |
|
|
"}\n"
|
6602 |
|
|
"}\n"
|
6603 |
|
|
"bind Text <Control-o> {\n"
|
6604 |
|
|
"if {!$tk_strictMotif} {\n"
|
6605 |
|
|
"%W insert insert \\n\n"
|
6606 |
|
|
"%W mark set insert insert-1c\n"
|
6607 |
|
|
"}\n"
|
6608 |
|
|
"}\n"
|
6609 |
|
|
"bind Text <Control-p> {\n"
|
6610 |
|
|
"if {!$tk_strictMotif} {\n"
|
6611 |
|
|
"tkTextSetCursor %W [tkTextUpDownLine %W -1]\n"
|
6612 |
|
|
"}\n"
|
6613 |
|
|
"}\n"
|
6614 |
|
|
"bind Text <Control-t> {\n"
|
6615 |
|
|
"if {!$tk_strictMotif} {\n"
|
6616 |
|
|
"tkTextTranspose %W\n"
|
6617 |
|
|
"}\n"
|
6618 |
|
|
"}\n"
|
6619 |
|
|
"if {[string compare $tcl_platform(platform) \"windows\"]} {\n"
|
6620 |
|
|
"bind Text <Control-v> {\n"
|
6621 |
|
|
"if {!$tk_strictMotif} {\n"
|
6622 |
|
|
"tkTextScrollPages %W 1\n"
|
6623 |
|
|
"}\n"
|
6624 |
|
|
"}\n"
|
6625 |
|
|
"}\n"
|
6626 |
|
|
"bind Text <Meta-b> {\n"
|
6627 |
|
|
"if {!$tk_strictMotif} {\n"
|
6628 |
|
|
"tkTextSetCursor %W [tkTextPrevPos %W insert tcl_startOfPreviousWord]\n"
|
6629 |
|
|
"}\n"
|
6630 |
|
|
"}\n"
|
6631 |
|
|
"bind Text <Meta-d> {\n"
|
6632 |
|
|
"if {!$tk_strictMotif} {\n"
|
6633 |
|
|
"%W delete insert [tkTextNextWord %W insert]\n"
|
6634 |
|
|
"}\n"
|
6635 |
|
|
"}\n"
|
6636 |
|
|
"bind Text <Meta-f> {\n"
|
6637 |
|
|
"if {!$tk_strictMotif} {\n"
|
6638 |
|
|
"tkTextSetCursor %W [tkTextNextWord %W insert]\n"
|
6639 |
|
|
"}\n"
|
6640 |
|
|
"}\n"
|
6641 |
|
|
"bind Text <Meta-less> {\n"
|
6642 |
|
|
"if {!$tk_strictMotif} {\n"
|
6643 |
|
|
"tkTextSetCursor %W 1.0\n"
|
6644 |
|
|
"}\n"
|
6645 |
|
|
"}\n"
|
6646 |
|
|
"bind Text <Meta-greater> {\n"
|
6647 |
|
|
"if {!$tk_strictMotif} {\n"
|
6648 |
|
|
"tkTextSetCursor %W end-1c\n"
|
6649 |
|
|
"}\n"
|
6650 |
|
|
"}\n"
|
6651 |
|
|
"bind Text <Meta-BackSpace> {\n"
|
6652 |
|
|
"if {!$tk_strictMotif} {\n"
|
6653 |
|
|
"%W delete [tkTextPrevPos %W insert tcl_startOfPreviousWord] insert\n"
|
6654 |
|
|
"}\n"
|
6655 |
|
|
"}\n"
|
6656 |
|
|
"bind Text <Meta-Delete> {\n"
|
6657 |
|
|
"if {!$tk_strictMotif} {\n"
|
6658 |
|
|
"%W delete [tkTextPrevPos %W insert tcl_startOfPreviousWord] insert\n"
|
6659 |
|
|
"}\n"
|
6660 |
|
|
"}\n"
|
6661 |
|
|
"if {[string equal $tcl_platform(platform) \"macintosh\"]} {\n"
|
6662 |
|
|
"bind Text <FocusIn> {\n"
|
6663 |
|
|
"%W tag configure sel -borderwidth 0\n"
|
6664 |
|
|
"%W configure -selectbackground systemHighlight -selectforeground systemHighlightText\n"
|
6665 |
|
|
"}\n"
|
6666 |
|
|
"bind Text <FocusOut> {\n"
|
6667 |
|
|
"%W tag configure sel -borderwidth 1\n"
|
6668 |
|
|
"%W configure -selectbackground white -selectforeground black\n"
|
6669 |
|
|
"}\n"
|
6670 |
|
|
"bind Text <Option-Left> {\n"
|
6671 |
|
|
"tkTextSetCursor %W [tkTextPrevPos %W insert tcl_startOfPreviousWord]\n"
|
6672 |
|
|
"}\n"
|
6673 |
|
|
"bind Text <Option-Right> {\n"
|
6674 |
|
|
"tkTextSetCursor %W [tkTextNextWord %W insert]\n"
|
6675 |
|
|
"}\n"
|
6676 |
|
|
"bind Text <Option-Up> {\n"
|
6677 |
|
|
"tkTextSetCursor %W [tkTextPrevPara %W insert]\n"
|
6678 |
|
|
"}\n"
|
6679 |
|
|
"bind Text <Option-Down> {\n"
|
6680 |
|
|
"tkTextSetCursor %W [tkTextNextPara %W insert]\n"
|
6681 |
|
|
"}\n"
|
6682 |
|
|
"bind Text <Shift-Option-Left> {\n"
|
6683 |
|
|
"tkTextKeySelect %W [tkTextPrevPos %W insert tcl_startOfPreviousWord]\n"
|
6684 |
|
|
"}\n"
|
6685 |
|
|
"bind Text <Shift-Option-Right> {\n"
|
6686 |
|
|
"tkTextKeySelect %W [tkTextNextWord %W insert]\n"
|
6687 |
|
|
"}\n"
|
6688 |
|
|
"bind Text <Shift-Option-Up> {\n"
|
6689 |
|
|
"tkTextKeySelect %W [tkTextPrevPara %W insert]\n"
|
6690 |
|
|
"}\n"
|
6691 |
|
|
"bind Text <Shift-Option-Down> {\n"
|
6692 |
|
|
"tkTextKeySelect %W [tkTextNextPara %W insert]\n"
|
6693 |
|
|
"}\n"
|
6694 |
|
|
"}\n"
|
6695 |
|
|
"bind Text <Control-h> {\n"
|
6696 |
|
|
"if {!$tk_strictMotif} {\n"
|
6697 |
|
|
"if {[%W compare insert != 1.0]} {\n"
|
6698 |
|
|
"%W delete insert-1c\n"
|
6699 |
|
|
"%W see insert\n"
|
6700 |
|
|
"}\n"
|
6701 |
|
|
"}\n"
|
6702 |
|
|
"}\n"
|
6703 |
|
|
"bind Text <2> {\n"
|
6704 |
|
|
"if {!$tk_strictMotif} {\n"
|
6705 |
|
|
"%W scan mark %x %y\n"
|
6706 |
|
|
"set tkPriv(x) %x\n"
|
6707 |
|
|
"set tkPriv(y) %y\n"
|
6708 |
|
|
"set tkPriv(mouseMoved) 0\n"
|
6709 |
|
|
"}\n"
|
6710 |
|
|
"}\n"
|
6711 |
|
|
"bind Text <B2-Motion> {\n"
|
6712 |
|
|
"if {!$tk_strictMotif} {\n"
|
6713 |
|
|
"if {(%x != $tkPriv(x)) || (%y != $tkPriv(y))} {\n"
|
6714 |
|
|
"set tkPriv(mouseMoved) 1\n"
|
6715 |
|
|
"}\n"
|
6716 |
|
|
"if {$tkPriv(mouseMoved)} {\n"
|
6717 |
|
|
"%W scan dragto %x %y\n"
|
6718 |
|
|
"}\n"
|
6719 |
|
|
"}\n"
|
6720 |
|
|
"}\n"
|
6721 |
|
|
"set tkPriv(prevPos) {}\n"
|
6722 |
|
|
"bind Text <MouseWheel> {\n"
|
6723 |
|
|
"%W yview scroll [expr {- (%D / 120) * 4}] units\n"
|
6724 |
|
|
"}\n"
|
6725 |
|
|
"if {[string equal \"unix\" $tcl_platform(platform)]} {\n"
|
6726 |
|
|
"bind Text <4> {\n"
|
6727 |
|
|
"if {!$tk_strictMotif} {\n"
|
6728 |
|
|
"%W yview scroll -5 units\n"
|
6729 |
|
|
"}\n"
|
6730 |
|
|
"}\n"
|
6731 |
|
|
"bind Text <5> {\n"
|
6732 |
|
|
"if {!$tk_strictMotif} {\n"
|
6733 |
|
|
"%W yview scroll 5 units\n"
|
6734 |
|
|
"}\n"
|
6735 |
|
|
"}\n"
|
6736 |
|
|
"}\n"
|
6737 |
|
|
"proc tkTextClosestGap {w x y} {\n"
|
6738 |
|
|
"set pos [$w index @$x,$y]\n"
|
6739 |
|
|
"set bbox [$w bbox $pos]\n"
|
6740 |
|
|
"if {[string equal $bbox \"\"]} {\n"
|
6741 |
|
|
"return $pos\n"
|
6742 |
|
|
"}\n"
|
6743 |
|
|
"if {($x - [lindex $bbox 0]) < ([lindex $bbox 2]/2)} {\n"
|
6744 |
|
|
"return $pos\n"
|
6745 |
|
|
"}\n"
|
6746 |
|
|
"$w index \"$pos + 1 char\"\n"
|
6747 |
|
|
"}\n"
|
6748 |
|
|
"proc tkTextButton1 {w x y} {\n"
|
6749 |
|
|
"global tkPriv\n"
|
6750 |
|
|
"set tkPriv(selectMode) char\n"
|
6751 |
|
|
"set tkPriv(mouseMoved) 0\n"
|
6752 |
|
|
"set tkPriv(pressX) $x\n"
|
6753 |
|
|
"$w mark set insert [tkTextClosestGap $w $x $y]\n"
|
6754 |
|
|
"$w mark set anchor insert\n"
|
6755 |
|
|
"if {[string equal [$w cget -state] \"normal\"]} {focus $w}\n"
|
6756 |
|
|
"}\n"
|
6757 |
|
|
"proc tkTextSelectTo {w x y {extend 0}} {\n"
|
6758 |
|
|
"global tkPriv tcl_platform\n"
|
6759 |
|
|
"set cur [tkTextClosestGap $w $x $y]\n"
|
6760 |
|
|
"if {[catch {$w index anchor}]} {\n"
|
6761 |
|
|
"$w mark set anchor $cur\n"
|
6762 |
|
|
"}\n"
|
6763 |
|
|
"set anchor [$w index anchor]\n"
|
6764 |
|
|
"if {[$w compare $cur != $anchor] || (abs($tkPriv(pressX) - $x) >= 3)} {\n"
|
6765 |
|
|
"set tkPriv(mouseMoved) 1\n"
|
6766 |
|
|
"}\n"
|
6767 |
|
|
"switch $tkPriv(selectMode) {\n"
|
6768 |
|
|
"char {\n"
|
6769 |
|
|
"if {[$w compare $cur < anchor]} {\n"
|
6770 |
|
|
"set first $cur\n"
|
6771 |
|
|
"set last anchor\n"
|
6772 |
|
|
"} else {\n"
|
6773 |
|
|
"set first anchor\n"
|
6774 |
|
|
"set last $cur\n"
|
6775 |
|
|
"}\n"
|
6776 |
|
|
"}\n"
|
6777 |
|
|
"word {\n"
|
6778 |
|
|
"if {[$w compare $cur < anchor]} {\n"
|
6779 |
|
|
"set first [tkTextPrevPos $w \"$cur + 1c\" tcl_wordBreakBefore]\n"
|
6780 |
|
|
"if { !$extend } {\n"
|
6781 |
|
|
"set last [tkTextNextPos $w \"anchor\" tcl_wordBreakAfter]\n"
|
6782 |
|
|
"} else {\n"
|
6783 |
|
|
"set last anchor\n"
|
6784 |
|
|
"}\n"
|
6785 |
|
|
"} else {\n"
|
6786 |
|
|
"set last [tkTextNextPos $w \"$cur - 1c\" tcl_wordBreakAfter]\n"
|
6787 |
|
|
"if { !$extend } {\n"
|
6788 |
|
|
"set first [tkTextPrevPos $w anchor tcl_wordBreakBefore]\n"
|
6789 |
|
|
"} else {\n"
|
6790 |
|
|
"set first anchor\n"
|
6791 |
|
|
"}\n"
|
6792 |
|
|
"}\n"
|
6793 |
|
|
"}\n"
|
6794 |
|
|
"line {\n"
|
6795 |
|
|
"if {[$w compare $cur < anchor]} {\n"
|
6796 |
|
|
"set first [$w index \"$cur linestart\"]\n"
|
6797 |
|
|
"set last [$w index \"anchor - 1c lineend + 1c\"]\n"
|
6798 |
|
|
"} else {\n"
|
6799 |
|
|
"set first [$w index \"anchor linestart\"]\n"
|
6800 |
|
|
"set last [$w index \"$cur lineend + 1c\"]\n"
|
6801 |
|
|
"}\n"
|
6802 |
|
|
"}\n"
|
6803 |
|
|
"}\n"
|
6804 |
|
|
"if {$tkPriv(mouseMoved) || [string compare $tkPriv(selectMode) \"char\"]} {\n"
|
6805 |
|
|
"if {[string compare $tcl_platform(platform) \"unix\"] \\\n"
|
6806 |
|
|
"\011\011&& [$w compare $cur < anchor]} {\n"
|
6807 |
|
|
"$w mark set insert $first\n"
|
6808 |
|
|
"} else {\n"
|
6809 |
|
|
"$w mark set insert $last\n"
|
6810 |
|
|
"}\n"
|
6811 |
|
|
"$w tag remove sel 0.0 $first\n"
|
6812 |
|
|
"$w tag add sel $first $last\n"
|
6813 |
|
|
"$w tag remove sel $last end\n"
|
6814 |
|
|
"update idletasks\n"
|
6815 |
|
|
"}\n"
|
6816 |
|
|
"}\n"
|
6817 |
|
|
"proc tkTextKeyExtend {w index} {\n"
|
6818 |
|
|
"global tkPriv\n"
|
6819 |
|
|
"set cur [$w index $index]\n"
|
6820 |
|
|
"if {[catch {$w index anchor}]} {\n"
|
6821 |
|
|
"$w mark set anchor $cur\n"
|
6822 |
|
|
"}\n"
|
6823 |
|
|
"set anchor [$w index anchor]\n"
|
6824 |
|
|
"if {[$w compare $cur < anchor]} {\n"
|
6825 |
|
|
"set first $cur\n"
|
6826 |
|
|
"set last anchor\n"
|
6827 |
|
|
"} else {\n"
|
6828 |
|
|
"set first anchor\n"
|
6829 |
|
|
"set last $cur\n"
|
6830 |
|
|
"}\n"
|
6831 |
|
|
"$w tag remove sel 0.0 $first\n"
|
6832 |
|
|
"$w tag add sel $first $last\n"
|
6833 |
|
|
"$w tag remove sel $last end\n"
|
6834 |
|
|
"}\n"
|
6835 |
|
|
"proc tkTextPaste {w x y} {\n"
|
6836 |
|
|
"$w mark set insert [tkTextClosestGap $w $x $y]\n"
|
6837 |
|
|
"catch {$w insert insert [selection get -displayof $w]}\n"
|
6838 |
|
|
"if {[string equal [$w cget -state] \"normal\"]} {focus $w}\n"
|
6839 |
|
|
"}\n"
|
6840 |
|
|
"proc tkTextAutoScan {w} {\n"
|
6841 |
|
|
"global tkPriv\n"
|
6842 |
|
|
"if {![winfo exists $w]} return\n"
|
6843 |
|
|
"if {$tkPriv(y) >= [winfo height $w]} {\n"
|
6844 |
|
|
"$w yview scroll 2 units\n"
|
6845 |
|
|
"} elseif {$tkPriv(y) < 0} {\n"
|
6846 |
|
|
"$w yview scroll -2 units\n"
|
6847 |
|
|
"} elseif {$tkPriv(x) >= [winfo width $w]} {\n"
|
6848 |
|
|
"$w xview scroll 2 units\n"
|
6849 |
|
|
"} elseif {$tkPriv(x) < 0} {\n"
|
6850 |
|
|
"$w xview scroll -2 units\n"
|
6851 |
|
|
"} else {\n"
|
6852 |
|
|
"return\n"
|
6853 |
|
|
"}\n"
|
6854 |
|
|
"tkTextSelectTo $w $tkPriv(x) $tkPriv(y)\n"
|
6855 |
|
|
"set tkPriv(afterId) [after 50 [list tkTextAutoScan $w]]\n"
|
6856 |
|
|
"}\n"
|
6857 |
|
|
"proc tkTextSetCursor {w pos} {\n"
|
6858 |
|
|
"global tkPriv\n"
|
6859 |
|
|
"if {[$w compare $pos == end]} {\n"
|
6860 |
|
|
"set pos {end - 1 chars}\n"
|
6861 |
|
|
"}\n"
|
6862 |
|
|
"$w mark set insert $pos\n"
|
6863 |
|
|
"$w tag remove sel 1.0 end\n"
|
6864 |
|
|
"$w see insert\n"
|
6865 |
|
|
"}\n"
|
6866 |
|
|
"proc tkTextKeySelect {w new} {\n"
|
6867 |
|
|
"global tkPriv\n"
|
6868 |
|
|
"if {[string equal [$w tag nextrange sel 1.0 end] \"\"]} {\n"
|
6869 |
|
|
"if {[$w compare $new < insert]} {\n"
|
6870 |
|
|
"$w tag add sel $new insert\n"
|
6871 |
|
|
"} else {\n"
|
6872 |
|
|
"$w tag add sel insert $new\n"
|
6873 |
|
|
"}\n"
|
6874 |
|
|
"$w mark set anchor insert\n"
|
6875 |
|
|
"} else {\n"
|
6876 |
|
|
"if {[$w compare $new < anchor]} {\n"
|
6877 |
|
|
"set first $new\n"
|
6878 |
|
|
"set last anchor\n"
|
6879 |
|
|
"} else {\n"
|
6880 |
|
|
"set first anchor\n"
|
6881 |
|
|
"set last $new\n"
|
6882 |
|
|
"}\n"
|
6883 |
|
|
"$w tag remove sel 1.0 $first\n"
|
6884 |
|
|
"$w tag add sel $first $last\n"
|
6885 |
|
|
"$w tag remove sel $last end\n"
|
6886 |
|
|
"}\n"
|
6887 |
|
|
"$w mark set insert $new\n"
|
6888 |
|
|
"$w see insert\n"
|
6889 |
|
|
"update idletasks\n"
|
6890 |
|
|
"}\n"
|
6891 |
|
|
"proc tkTextResetAnchor {w index} {\n"
|
6892 |
|
|
"global tkPriv\n"
|
6893 |
|
|
"if {[string equal [$w tag ranges sel] \"\"]} {\n"
|
6894 |
|
|
"$w mark set anchor $index\n"
|
6895 |
|
|
"return\n"
|
6896 |
|
|
"}\n"
|
6897 |
|
|
"set a [$w index $index]\n"
|
6898 |
|
|
"set b [$w index sel.first]\n"
|
6899 |
|
|
"set c [$w index sel.last]\n"
|
6900 |
|
|
"if {[$w compare $a < $b]} {\n"
|
6901 |
|
|
"$w mark set anchor sel.last\n"
|
6902 |
|
|
"return\n"
|
6903 |
|
|
"}\n"
|
6904 |
|
|
"if {[$w compare $a > $c]} {\n"
|
6905 |
|
|
"$w mark set anchor sel.first\n"
|
6906 |
|
|
"return\n"
|
6907 |
|
|
"}\n"
|
6908 |
|
|
"scan $a \"%d.%d\" lineA chA\n"
|
6909 |
|
|
"scan $b \"%d.%d\" lineB chB\n"
|
6910 |
|
|
"scan $c \"%d.%d\" lineC chC\n"
|
6911 |
|
|
"if {$lineB < $lineC+2} {\n"
|
6912 |
|
|
"set total [string length [$w get $b $c]]\n"
|
6913 |
|
|
"if {$total <= 2} {\n"
|
6914 |
|
|
"return\n"
|
6915 |
|
|
"}\n"
|
6916 |
|
|
"if {[string length [$w get $b $a]] < ($total/2)} {\n"
|
6917 |
|
|
"$w mark set anchor sel.last\n"
|
6918 |
|
|
"} else {\n"
|
6919 |
|
|
"$w mark set anchor sel.first\n"
|
6920 |
|
|
"}\n"
|
6921 |
|
|
"return\n"
|
6922 |
|
|
"}\n"
|
6923 |
|
|
"if {($lineA-$lineB) < ($lineC-$lineA)} {\n"
|
6924 |
|
|
"$w mark set anchor sel.last\n"
|
6925 |
|
|
"} else {\n"
|
6926 |
|
|
"$w mark set anchor sel.first\n"
|
6927 |
|
|
"}\n"
|
6928 |
|
|
"}\n"
|
6929 |
|
|
"proc tkTextInsert {w s} {\n"
|
6930 |
|
|
"if {[string equal $s \"\"] || [string equal [$w cget -state] \"disabled\"]} {\n"
|
6931 |
|
|
"return\n"
|
6932 |
|
|
"}\n"
|
6933 |
|
|
"catch {\n"
|
6934 |
|
|
"if {[$w compare sel.first <= insert] \\\n"
|
6935 |
|
|
"\011\011&& [$w compare sel.last >= insert]} {\n"
|
6936 |
|
|
"$w delete sel.first sel.last\n"
|
6937 |
|
|
"}\n"
|
6938 |
|
|
"}\n"
|
6939 |
|
|
"$w insert insert $s\n"
|
6940 |
|
|
"$w see insert\n"
|
6941 |
|
|
"}\n"
|
6942 |
|
|
"proc tkTextUpDownLine {w n} {\n"
|
6943 |
|
|
"global tkPriv\n"
|
6944 |
|
|
"set i [$w index insert]\n"
|
6945 |
|
|
"scan $i \"%d.%d\" line char\n"
|
6946 |
|
|
"if {[string compare $tkPriv(prevPos) $i]} {\n"
|
6947 |
|
|
"set tkPriv(char) $char\n"
|
6948 |
|
|
"}\n"
|
6949 |
|
|
"set new [$w index [expr {$line + $n}].$tkPriv(char)]\n"
|
6950 |
|
|
"if {[$w compare $new == end] || [$w compare $new == \"insert linestart\"]} {\n"
|
6951 |
|
|
"set new $i\n"
|
6952 |
|
|
"}\n"
|
6953 |
|
|
"set tkPriv(prevPos) $new\n"
|
6954 |
|
|
"return $new\n"
|
6955 |
|
|
"}\n"
|
6956 |
|
|
"proc tkTextPrevPara {w pos} {\n"
|
6957 |
|
|
"set pos [$w index \"$pos linestart\"]\n"
|
6958 |
|
|
"while {1} {\n"
|
6959 |
|
|
"if {([string equal [$w get \"$pos - 1 line\"] \"\\n\"] \\\n"
|
6960 |
|
|
"\011\011&& [string compare [$w get $pos] \"\\n\"]) \\\n"
|
6961 |
|
|
"\011\011|| [string equal $pos \"1.0\"]} {\n"
|
6962 |
|
|
"if {[regexp -indices {^[ \011]+(.)} [$w get $pos \"$pos lineend\"] \\\n"
|
6963 |
|
|
"\011\011 dummy index]} {\n"
|
6964 |
|
|
"set pos [$w index \"$pos + [lindex $index 0] chars\"]\n"
|
6965 |
|
|
"}\n"
|
6966 |
|
|
"if {[$w compare $pos != insert] || [string equal $pos 1.0]} {\n"
|
6967 |
|
|
"return $pos\n"
|
6968 |
|
|
"}\n"
|
6969 |
|
|
"}\n"
|
6970 |
|
|
"set pos [$w index \"$pos - 1 line\"]\n"
|
6971 |
|
|
"}\n"
|
6972 |
|
|
"}\n"
|
6973 |
|
|
"proc tkTextNextPara {w start} {\n"
|
6974 |
|
|
"set pos [$w index \"$start linestart + 1 line\"]\n"
|
6975 |
|
|
"while {[string compare [$w get $pos] \"\\n\"]} {\n"
|
6976 |
|
|
"if {[$w compare $pos == end]} {\n"
|
6977 |
|
|
"return [$w index \"end - 1c\"]\n"
|
6978 |
|
|
"}\n"
|
6979 |
|
|
"set pos [$w index \"$pos + 1 line\"]\n"
|
6980 |
|
|
"}\n"
|
6981 |
|
|
"while {[string equal [$w get $pos] \"\\n\"]} {\n"
|
6982 |
|
|
"set pos [$w index \"$pos + 1 line\"]\n"
|
6983 |
|
|
"if {[$w compare $pos == end]} {\n"
|
6984 |
|
|
"return [$w index \"end - 1c\"]\n"
|
6985 |
|
|
"}\n"
|
6986 |
|
|
"}\n"
|
6987 |
|
|
"if {[regexp -indices {^[ \011]+(.)} [$w get $pos \"$pos lineend\"] \\\n"
|
6988 |
|
|
"\011 dummy index]} {\n"
|
6989 |
|
|
"return [$w index \"$pos + [lindex $index 0] chars\"]\n"
|
6990 |
|
|
"}\n"
|
6991 |
|
|
"return $pos\n"
|
6992 |
|
|
"}\n"
|
6993 |
|
|
"proc tkTextScrollPages {w count} {\n"
|
6994 |
|
|
"set bbox [$w bbox insert]\n"
|
6995 |
|
|
"$w yview scroll $count pages\n"
|
6996 |
|
|
"if {[string equal $bbox \"\"]} {\n"
|
6997 |
|
|
"return [$w index @[expr {[winfo height $w]/2}],0]\n"
|
6998 |
|
|
"}\n"
|
6999 |
|
|
"return [$w index @[lindex $bbox 0],[lindex $bbox 1]]\n"
|
7000 |
|
|
"}\n"
|
7001 |
|
|
"proc tkTextTranspose w {\n"
|
7002 |
|
|
"set pos insert\n"
|
7003 |
|
|
"if {[$w compare $pos != \"$pos lineend\"]} {\n"
|
7004 |
|
|
"set pos [$w index \"$pos + 1 char\"]\n"
|
7005 |
|
|
"}\n"
|
7006 |
|
|
"set new [$w get \"$pos - 1 char\"][$w get \"$pos - 2 char\"]\n"
|
7007 |
|
|
"if {[$w compare \"$pos - 1 char\" == 1.0]} {\n"
|
7008 |
|
|
"return\n"
|
7009 |
|
|
"}\n"
|
7010 |
|
|
"$w delete \"$pos - 2 char\" $pos\n"
|
7011 |
|
|
"$w insert insert $new\n"
|
7012 |
|
|
"$w see insert\n"
|
7013 |
|
|
"}\n"
|
7014 |
|
|
"proc tk_textCopy w {\n"
|
7015 |
|
|
"if {![catch {set data [$w get sel.first sel.last]}]} {\n"
|
7016 |
|
|
"clipboard clear -displayof $w\n"
|
7017 |
|
|
"clipboard append -displayof $w $data\n"
|
7018 |
|
|
"}\n"
|
7019 |
|
|
"}\n"
|
7020 |
|
|
"proc tk_textCut w {\n"
|
7021 |
|
|
"if {![catch {set data [$w get sel.first sel.last]}]} {\n"
|
7022 |
|
|
"clipboard clear -displayof $w\n"
|
7023 |
|
|
"clipboard append -displayof $w $data\n"
|
7024 |
|
|
"$w delete sel.first sel.last\n"
|
7025 |
|
|
"}\n"
|
7026 |
|
|
"}\n"
|
7027 |
|
|
"proc tk_textPaste w {\n"
|
7028 |
|
|
"global tcl_platform\n"
|
7029 |
|
|
"catch {\n"
|
7030 |
|
|
"if {[string compare $tcl_platform(platform) \"unix\"]} {\n"
|
7031 |
|
|
"catch {\n"
|
7032 |
|
|
"$w delete sel.first sel.last\n"
|
7033 |
|
|
"}\n"
|
7034 |
|
|
"}\n"
|
7035 |
|
|
"$w insert insert [selection get -displayof $w -selection CLIPBOARD]\n"
|
7036 |
|
|
"}\n"
|
7037 |
|
|
"}\n"
|
7038 |
|
|
"if {[string equal $tcl_platform(platform) \"windows\"]} {\n"
|
7039 |
|
|
"proc tkTextNextWord {w start} {\n"
|
7040 |
|
|
"tkTextNextPos $w [tkTextNextPos $w $start tcl_endOfWord] \\\n"
|
7041 |
|
|
"\011 tcl_startOfNextWord\n"
|
7042 |
|
|
"}\n"
|
7043 |
|
|
"} else {\n"
|
7044 |
|
|
"proc tkTextNextWord {w start} {\n"
|
7045 |
|
|
"tkTextNextPos $w $start tcl_endOfWord\n"
|
7046 |
|
|
"}\n"
|
7047 |
|
|
"}\n"
|
7048 |
|
|
"proc tkTextNextPos {w start op} {\n"
|
7049 |
|
|
"set text \"\"\n"
|
7050 |
|
|
"set cur $start\n"
|
7051 |
|
|
"while {[$w compare $cur < end]} {\n"
|
7052 |
|
|
"set text $text[$w get $cur \"$cur lineend + 1c\"]\n"
|
7053 |
|
|
"set pos [$op $text 0]\n"
|
7054 |
|
|
"if {$pos >= 0} {\n"
|
7055 |
|
|
"set dump [$w dump -image -window $start \"$start + $pos c\"]\n"
|
7056 |
|
|
"if {[llength $dump]} {\n"
|
7057 |
|
|
"set pos [expr {$pos + ([llength $dump]/3)}]\n"
|
7058 |
|
|
"}\n"
|
7059 |
|
|
"return [$w index \"$start + $pos c\"]\n"
|
7060 |
|
|
"}\n"
|
7061 |
|
|
"set cur [$w index \"$cur lineend +1c\"]\n"
|
7062 |
|
|
"}\n"
|
7063 |
|
|
"return end\n"
|
7064 |
|
|
"}\n"
|
7065 |
|
|
"proc tkTextPrevPos {w start op} {\n"
|
7066 |
|
|
"set text \"\"\n"
|
7067 |
|
|
"set cur $start\n"
|
7068 |
|
|
"while {[$w compare $cur > 0.0]} {\n"
|
7069 |
|
|
"set text [$w get \"$cur linestart - 1c\" $cur]$text\n"
|
7070 |
|
|
"set pos [$op $text end]\n"
|
7071 |
|
|
"if {$pos >= 0} {\n"
|
7072 |
|
|
"set dump [$w dump -image -window \"$cur linestart\" \"$start - 1c\"]\n"
|
7073 |
|
|
"if {[llength $dump]} {\n"
|
7074 |
|
|
"if {[$w compare [lindex $dump 2] > \\\n"
|
7075 |
|
|
"\011\011\011\"$cur linestart - 1c + $pos c\"]} {\n"
|
7076 |
|
|
"incr pos -1\n"
|
7077 |
|
|
"}\n"
|
7078 |
|
|
"set pos [expr {$pos + ([llength $dump]/3)}]\n"
|
7079 |
|
|
"}\n"
|
7080 |
|
|
"return [$w index \"$cur linestart - 1c + $pos c\"]\n"
|
7081 |
|
|
"}\n"
|
7082 |
|
|
"set cur [$w index \"$cur linestart - 1c\"]\n"
|
7083 |
|
|
"}\n"
|
7084 |
|
|
"return 0.0\n"
|
7085 |
|
|
"}\n"
|
7086 |
|
|
;
|
7087 |
|
|
static char Et_zFile28[] =
|
7088 |
|
|
"package require -exact Tk 8.3\n"
|
7089 |
|
|
"package require -exact Tcl 8.3\n"
|
7090 |
|
|
"if {[info exists auto_path] && [string compare {} $tk_library] && \\\n"
|
7091 |
|
|
"\011[lsearch -exact $auto_path $tk_library] < 0} {\n"
|
7092 |
|
|
"lappend auto_path $tk_library\n"
|
7093 |
|
|
"}\n"
|
7094 |
|
|
"set tk_strictMotif 0\n"
|
7095 |
|
|
"namespace eval ::tk {\n"
|
7096 |
|
|
"}\n"
|
7097 |
|
|
"proc ::tk::PlaceWindow {w {place \"\"} {anchor \"\"}} {\n"
|
7098 |
|
|
"wm withdraw $w\n"
|
7099 |
|
|
"update idletasks\n"
|
7100 |
|
|
"set checkBounds 1\n"
|
7101 |
|
|
"if {[string equal -len [string length $place] $place \"pointer\"]} {\n"
|
7102 |
|
|
"if {[string equal -len [string length $anchor] $anchor \"center\"]} {\n"
|
7103 |
|
|
"set x [expr {[winfo pointerx $w]-[winfo reqwidth $w]/2}]\n"
|
7104 |
|
|
"set y [expr {[winfo pointery $w]-[winfo reqheight $w]/2}]\n"
|
7105 |
|
|
"} else {\n"
|
7106 |
|
|
"set x [winfo pointerx $w]\n"
|
7107 |
|
|
"set y [winfo pointery $w]\n"
|
7108 |
|
|
"}\n"
|
7109 |
|
|
"} elseif {[string equal -len [string length $place] $place \"widget\"] && \\\n"
|
7110 |
|
|
"\011 [winfo exists $anchor] && [winfo ismapped $anchor]} {\n"
|
7111 |
|
|
"set x [expr {[winfo rootx $anchor] + \\\n"
|
7112 |
|
|
"\011\011([winfo width $anchor]-[winfo reqwidth $w])/2}]\n"
|
7113 |
|
|
"set y [expr {[winfo rooty $anchor] + \\\n"
|
7114 |
|
|
"\011\011([winfo height $anchor]-[winfo reqheight $w])/2}]\n"
|
7115 |
|
|
"} else {\n"
|
7116 |
|
|
"set x [expr {([winfo screenwidth $w]-[winfo reqwidth $w])/2}]\n"
|
7117 |
|
|
"set y [expr {([winfo screenheight $w]-[winfo reqheight $w])/2}]\n"
|
7118 |
|
|
"set checkBounds 0\n"
|
7119 |
|
|
"}\n"
|
7120 |
|
|
"if {$checkBounds} {\n"
|
7121 |
|
|
"if {$x < 0} {\n"
|
7122 |
|
|
"set x 0\n"
|
7123 |
|
|
"} elseif {$x > ([winfo screenwidth $w]-[winfo reqwidth $w])} {\n"
|
7124 |
|
|
"set x [expr {[winfo screenwidth $w]-[winfo reqwidth $w]}]\n"
|
7125 |
|
|
"}\n"
|
7126 |
|
|
"if {$y < 0} {\n"
|
7127 |
|
|
"set y 0\n"
|
7128 |
|
|
"} elseif {$y > ([winfo screenheight $w]-[winfo reqheight $w])} {\n"
|
7129 |
|
|
"set y [expr {[winfo screenheight $w]-[winfo reqheight $w]}]\n"
|
7130 |
|
|
"}\n"
|
7131 |
|
|
"}\n"
|
7132 |
|
|
"wm geometry $w +$x+$y\n"
|
7133 |
|
|
"wm deiconify $w\n"
|
7134 |
|
|
"}\n"
|
7135 |
|
|
"proc ::tk::SetFocusGrab {grab {focus {}}} {\n"
|
7136 |
|
|
"set index \"$grab,$focus\"\n"
|
7137 |
|
|
"upvar ::tk::FocusGrab($index) data\n"
|
7138 |
|
|
"lappend data [focus]\n"
|
7139 |
|
|
"set oldGrab [grab current $grab]\n"
|
7140 |
|
|
"lappend data $oldGrab\n"
|
7141 |
|
|
"if {[winfo exists $oldGrab]} {\n"
|
7142 |
|
|
"lappend data [grab status $oldGrab]\n"
|
7143 |
|
|
"}\n"
|
7144 |
|
|
"grab $grab\n"
|
7145 |
|
|
"if {[winfo exists $focus]} {\n"
|
7146 |
|
|
"focus $focus\n"
|
7147 |
|
|
"}\n"
|
7148 |
|
|
"}\n"
|
7149 |
|
|
"proc ::tk::RestoreFocusGrab {grab focus {destroy destroy}} {\n"
|
7150 |
|
|
"set index \"$grab,$focus\"\n"
|
7151 |
|
|
"foreach {oldFocus oldGrab oldStatus} $::tk::FocusGrab($index) { break }\n"
|
7152 |
|
|
"unset ::tk::FocusGrab($index)\n"
|
7153 |
|
|
"catch {focus $oldFocus}\n"
|
7154 |
|
|
"grab release $grab\n"
|
7155 |
|
|
"if {[string equal $destroy \"withdraw\"]} {\n"
|
7156 |
|
|
"wm withdraw $grab\n"
|
7157 |
|
|
"} else {\n"
|
7158 |
|
|
"destroy $grab\n"
|
7159 |
|
|
"}\n"
|
7160 |
|
|
"if {[winfo exists $oldGrab] && [winfo ismapped $oldGrab]} {\n"
|
7161 |
|
|
"if {[string equal $oldStatus \"global\"]} {\n"
|
7162 |
|
|
"grab -global $oldGrab\n"
|
7163 |
|
|
"} else {\n"
|
7164 |
|
|
"grab $oldGrab\n"
|
7165 |
|
|
"}\n"
|
7166 |
|
|
"}\n"
|
7167 |
|
|
"}\n"
|
7168 |
|
|
"proc tkScreenChanged screen {\n"
|
7169 |
|
|
"set x [string last . $screen]\n"
|
7170 |
|
|
"if {$x > 0} {\n"
|
7171 |
|
|
"set disp [string range $screen 0 [expr {$x - 1}]]\n"
|
7172 |
|
|
"} else {\n"
|
7173 |
|
|
"set disp $screen\n"
|
7174 |
|
|
"}\n"
|
7175 |
|
|
"uplevel #0 upvar #0 tkPriv.$disp tkPriv\n"
|
7176 |
|
|
"global tkPriv\n"
|
7177 |
|
|
"global tcl_platform\n"
|
7178 |
|
|
"if {[info exists tkPriv]} {\n"
|
7179 |
|
|
"set tkPriv(screen) $screen\n"
|
7180 |
|
|
"return\n"
|
7181 |
|
|
"}\n"
|
7182 |
|
|
"array set tkPriv {\n"
|
7183 |
|
|
"activeMenu\011{}\n"
|
7184 |
|
|
"activeItem\011{}\n"
|
7185 |
|
|
"afterId\011\011{}\n"
|
7186 |
|
|
"buttons\011\0110\n"
|
7187 |
|
|
"buttonWindow\011{}\n"
|
7188 |
|
|
"dragging\0110\n"
|
7189 |
|
|
"focus\011\011{}\n"
|
7190 |
|
|
"grab\011\011{}\n"
|
7191 |
|
|
"initPos\011\011{}\n"
|
7192 |
|
|
"inMenubutton\011{}\n"
|
7193 |
|
|
"listboxPrev\011{}\n"
|
7194 |
|
|
"menuBar\011\011{}\n"
|
7195 |
|
|
"mouseMoved\0110\n"
|
7196 |
|
|
"oldGrab\011\011{}\n"
|
7197 |
|
|
"popup\011\011{}\n"
|
7198 |
|
|
"postedMb\011{}\n"
|
7199 |
|
|
"pressX\011\0110\n"
|
7200 |
|
|
"pressY\011\0110\n"
|
7201 |
|
|
"prevPos\011\0110\n"
|
7202 |
|
|
"selectMode\011char\n"
|
7203 |
|
|
"}\n"
|
7204 |
|
|
"set tkPriv(screen) $screen\n"
|
7205 |
|
|
"set tkPriv(tearoff) [string equal $tcl_platform(platform) \"unix\"]\n"
|
7206 |
|
|
"set tkPriv(window) {}\n"
|
7207 |
|
|
"}\n"
|
7208 |
|
|
"tkScreenChanged [winfo screen .]\n"
|
7209 |
|
|
"proc tkEventMotifBindings {n1 dummy dummy} {\n"
|
7210 |
|
|
"upvar $n1 name\n"
|
7211 |
|
|
"if {$name} {\n"
|
7212 |
|
|
"set op delete\n"
|
7213 |
|
|
"} else {\n"
|
7214 |
|
|
"set op add\n"
|
7215 |
|
|
"}\n"
|
7216 |
|
|
"event $op <<Cut>> <Control-Key-w>\n"
|
7217 |
|
|
"event $op <<Copy>> <Meta-Key-w> \n"
|
7218 |
|
|
"event $op <<Paste>> <Control-Key-y>\n"
|
7219 |
|
|
"}\n"
|
7220 |
|
|
"if {[string equal [info commands tk_chooseColor] \"\"]} {\n"
|
7221 |
|
|
"proc tk_chooseColor {args} {\n"
|
7222 |
|
|
"return [eval tkColorDialog $args]\n"
|
7223 |
|
|
"}\n"
|
7224 |
|
|
"}\n"
|
7225 |
|
|
"if {[string equal [info commands tk_getOpenFile] \"\"]} {\n"
|
7226 |
|
|
"proc tk_getOpenFile {args} {\n"
|
7227 |
|
|
"if {$::tk_strictMotif} {\n"
|
7228 |
|
|
"return [eval tkMotifFDialog open $args]\n"
|
7229 |
|
|
"} else {\n"
|
7230 |
|
|
"return [eval ::tk::dialog::file::tkFDialog open $args]\n"
|
7231 |
|
|
"}\n"
|
7232 |
|
|
"}\n"
|
7233 |
|
|
"}\n"
|
7234 |
|
|
"if {[string equal [info commands tk_getSaveFile] \"\"]} {\n"
|
7235 |
|
|
"proc tk_getSaveFile {args} {\n"
|
7236 |
|
|
"if {$::tk_strictMotif} {\n"
|
7237 |
|
|
"return [eval tkMotifFDialog save $args]\n"
|
7238 |
|
|
"} else {\n"
|
7239 |
|
|
"return [eval ::tk::dialog::file::tkFDialog save $args]\n"
|
7240 |
|
|
"}\n"
|
7241 |
|
|
"}\n"
|
7242 |
|
|
"}\n"
|
7243 |
|
|
"if {[string equal [info commands tk_messageBox] \"\"]} {\n"
|
7244 |
|
|
"proc tk_messageBox {args} {\n"
|
7245 |
|
|
"return [eval tkMessageBox $args]\n"
|
7246 |
|
|
"}\n"
|
7247 |
|
|
"}\n"
|
7248 |
|
|
"if {[string equal [info command tk_chooseDirectory] \"\"]} {\n"
|
7249 |
|
|
"proc tk_chooseDirectory {args} {\n"
|
7250 |
|
|
"return [eval ::tk::dialog::file::chooseDir::tkChooseDirectory $args]\n"
|
7251 |
|
|
"}\n"
|
7252 |
|
|
"}\n"
|
7253 |
|
|
"switch $tcl_platform(platform) {\n"
|
7254 |
|
|
"\"unix\" {\n"
|
7255 |
|
|
"event add <<Cut>> <Control-Key-x> <Key-F20> \n"
|
7256 |
|
|
"event add <<Copy>> <Control-Key-c> <Key-F16>\n"
|
7257 |
|
|
"event add <<Paste>> <Control-Key-v> <Key-F18>\n"
|
7258 |
|
|
"event add <<PasteSelection>> <ButtonRelease-2>\n"
|
7259 |
|
|
"if {[info exists tcl_platform(os)]} {\n"
|
7260 |
|
|
"switch $tcl_platform(os) {\n"
|
7261 |
|
|
"\"IRIX\" -\n"
|
7262 |
|
|
"\"Linux\" { event add <<PrevWindow>> <ISO_Left_Tab> }\n"
|
7263 |
|
|
"\"HP-UX\" { event add <<PrevWindow>> <hpBackTab> }\n"
|
7264 |
|
|
"}\n"
|
7265 |
|
|
"}\n"
|
7266 |
|
|
"trace variable tk_strictMotif w tkEventMotifBindings\n"
|
7267 |
|
|
"set tk_strictMotif $tk_strictMotif\n"
|
7268 |
|
|
"}\n"
|
7269 |
|
|
"\"windows\" {\n"
|
7270 |
|
|
"event add <<Cut>> <Control-Key-x> <Shift-Key-Delete>\n"
|
7271 |
|
|
"event add <<Copy>> <Control-Key-c> <Control-Key-Insert>\n"
|
7272 |
|
|
"event add <<Paste>> <Control-Key-v> <Shift-Key-Insert>\n"
|
7273 |
|
|
"event add <<PasteSelection>> <ButtonRelease-2>\n"
|
7274 |
|
|
"}\n"
|
7275 |
|
|
"\"macintosh\" {\n"
|
7276 |
|
|
"event add <<Cut>> <Control-Key-x> <Key-F2> \n"
|
7277 |
|
|
"event add <<Copy>> <Control-Key-c> <Key-F3>\n"
|
7278 |
|
|
"event add <<Paste>> <Control-Key-v> <Key-F4>\n"
|
7279 |
|
|
"event add <<PasteSelection>> <ButtonRelease-2>\n"
|
7280 |
|
|
"event add <<Clear>> <Clear>\n"
|
7281 |
|
|
"}\n"
|
7282 |
|
|
"}\n"
|
7283 |
|
|
"if {[string compare $tcl_platform(platform) \"macintosh\"] && \\\n"
|
7284 |
|
|
"\011[string compare {} $tk_library]} {\n"
|
7285 |
|
|
"source [file join $tk_library button.tcl]\n"
|
7286 |
|
|
"source [file join $tk_library entry.tcl]\n"
|
7287 |
|
|
"source [file join $tk_library listbox.tcl]\n"
|
7288 |
|
|
"source [file join $tk_library menu.tcl]\n"
|
7289 |
|
|
"source [file join $tk_library scale.tcl]\n"
|
7290 |
|
|
"source [file join $tk_library scrlbar.tcl]\n"
|
7291 |
|
|
"source [file join $tk_library text.tcl]\n"
|
7292 |
|
|
"}\n"
|
7293 |
|
|
"event add <<PrevWindow>> <Shift-Tab>\n"
|
7294 |
|
|
"bind all <Tab> {tkTabToWindow [tk_focusNext %W]}\n"
|
7295 |
|
|
"bind all <<PrevWindow>> {tkTabToWindow [tk_focusPrev %W]}\n"
|
7296 |
|
|
"proc tkCancelRepeat {} {\n"
|
7297 |
|
|
"global tkPriv\n"
|
7298 |
|
|
"after cancel $tkPriv(afterId)\n"
|
7299 |
|
|
"set tkPriv(afterId) {}\n"
|
7300 |
|
|
"}\n"
|
7301 |
|
|
"proc tkTabToWindow {w} {\n"
|
7302 |
|
|
"if {[string equal [winfo class $w] Entry]} {\n"
|
7303 |
|
|
"$w selection range 0 end\n"
|
7304 |
|
|
"$w icursor end\n"
|
7305 |
|
|
"}\n"
|
7306 |
|
|
"focus $w\n"
|
7307 |
|
|
"}\n"
|
7308 |
|
|
;
|
7309 |
|
|
static char Et_zFile29[] =
|
7310 |
|
|
"proc tkIconList {w args} {\n"
|
7311 |
|
|
"upvar #0 $w data\n"
|
7312 |
|
|
"tkIconList_Config $w $args\n"
|
7313 |
|
|
"tkIconList_Create $w\n"
|
7314 |
|
|
"}\n"
|
7315 |
|
|
"proc tkIconList_Config {w argList} {\n"
|
7316 |
|
|
"upvar #0 $w data\n"
|
7317 |
|
|
"set specs {\n"
|
7318 |
|
|
"{-browsecmd \"\" \"\" \"\"}\n"
|
7319 |
|
|
"{-command \"\" \"\" \"\"}\n"
|
7320 |
|
|
"}\n"
|
7321 |
|
|
"tclParseConfigSpec $w $specs \"\" $argList\n"
|
7322 |
|
|
"}\n"
|
7323 |
|
|
"proc tkIconList_Create {w} {\n"
|
7324 |
|
|
"upvar #0 $w data\n"
|
7325 |
|
|
"frame $w\n"
|
7326 |
|
|
"set data(sbar) [scrollbar $w.sbar -orient horizontal \\\n"
|
7327 |
|
|
"\011-highlightthickness 0 -takefocus 0]\n"
|
7328 |
|
|
"set data(canvas) [canvas $w.canvas -bd 2 -relief sunken \\\n"
|
7329 |
|
|
"\011-width 400 -height 120 -takefocus 1]\n"
|
7330 |
|
|
"pack $data(sbar) -side bottom -fill x -padx 2\n"
|
7331 |
|
|
"pack $data(canvas) -expand yes -fill both\n"
|
7332 |
|
|
"$data(sbar) config -command [list $data(canvas) xview]\n"
|
7333 |
|
|
"$data(canvas) config -xscrollcommand [list $data(sbar) set]\n"
|
7334 |
|
|
"set data(maxIW) 1\n"
|
7335 |
|
|
"set data(maxIH) 1\n"
|
7336 |
|
|
"set data(maxTW) 1\n"
|
7337 |
|
|
"set data(maxTH) 1\n"
|
7338 |
|
|
"set data(numItems) 0\n"
|
7339 |
|
|
"set data(curItem) {}\n"
|
7340 |
|
|
"set data(noScroll) 1\n"
|
7341 |
|
|
"bind $data(canvas) <Configure>\011[list tkIconList_Arrange $w]\n"
|
7342 |
|
|
"bind $data(canvas) <1>\011\011[list tkIconList_Btn1 $w %x %y]\n"
|
7343 |
|
|
"bind $data(canvas) <B1-Motion>\011[list tkIconList_Motion1 $w %x %y]\n"
|
7344 |
|
|
"bind $data(canvas) <B1-Leave>\011[list tkIconList_Leave1 $w %x %y]\n"
|
7345 |
|
|
"bind $data(canvas) <B1-Enter>\011[list tkCancelRepeat]\n"
|
7346 |
|
|
"bind $data(canvas) <ButtonRelease-1> [list tkCancelRepeat]\n"
|
7347 |
|
|
"bind $data(canvas) <Double-ButtonRelease-1> \\\n"
|
7348 |
|
|
"\011 [list tkIconList_Double1 $w %x %y]\n"
|
7349 |
|
|
"bind $data(canvas) <Up>\011\011[list tkIconList_UpDown $w -1]\n"
|
7350 |
|
|
"bind $data(canvas) <Down>\011\011[list tkIconList_UpDown $w 1]\n"
|
7351 |
|
|
"bind $data(canvas) <Left>\011\011[list tkIconList_LeftRight $w -1]\n"
|
7352 |
|
|
"bind $data(canvas) <Right>\011\011[list tkIconList_LeftRight $w 1]\n"
|
7353 |
|
|
"bind $data(canvas) <Return>\011\011[list tkIconList_ReturnKey $w]\n"
|
7354 |
|
|
"bind $data(canvas) <KeyPress>\011[list tkIconList_KeyPress $w %A]\n"
|
7355 |
|
|
"bind $data(canvas) <Control-KeyPress> \";\"\n"
|
7356 |
|
|
"bind $data(canvas) <Alt-KeyPress>\011\";\"\n"
|
7357 |
|
|
"bind $data(canvas) <FocusIn>\011[list tkIconList_FocusIn $w]\n"
|
7358 |
|
|
"return $w\n"
|
7359 |
|
|
"}\n"
|
7360 |
|
|
"proc tkIconList_AutoScan {w} {\n"
|
7361 |
|
|
"upvar #0 $w data\n"
|
7362 |
|
|
"global tkPriv\n"
|
7363 |
|
|
"if {![winfo exists $w]} return\n"
|
7364 |
|
|
"set x $tkPriv(x)\n"
|
7365 |
|
|
"set y $tkPriv(y)\n"
|
7366 |
|
|
"if {$data(noScroll)} {\n"
|
7367 |
|
|
"return\n"
|
7368 |
|
|
"}\n"
|
7369 |
|
|
"if {$x >= [winfo width $data(canvas)]} {\n"
|
7370 |
|
|
"$data(canvas) xview scroll 1 units\n"
|
7371 |
|
|
"} elseif {$x < 0} {\n"
|
7372 |
|
|
"$data(canvas) xview scroll -1 units\n"
|
7373 |
|
|
"} elseif {$y >= [winfo height $data(canvas)]} {\n"
|
7374 |
|
|
"} elseif {$y < 0} {\n"
|
7375 |
|
|
"} else {\n"
|
7376 |
|
|
"return\n"
|
7377 |
|
|
"}\n"
|
7378 |
|
|
"tkIconList_Motion1 $w $x $y\n"
|
7379 |
|
|
"set tkPriv(afterId) [after 50 [list tkIconList_AutoScan $w]]\n"
|
7380 |
|
|
"}\n"
|
7381 |
|
|
"proc tkIconList_DeleteAll {w} {\n"
|
7382 |
|
|
"upvar #0 $w data\n"
|
7383 |
|
|
"upvar #0 $w:itemList itemList\n"
|
7384 |
|
|
"$data(canvas) delete all\n"
|
7385 |
|
|
"catch {unset data(selected)}\n"
|
7386 |
|
|
"catch {unset data(rect)}\n"
|
7387 |
|
|
"catch {unset data(list)}\n"
|
7388 |
|
|
"catch {unset itemList}\n"
|
7389 |
|
|
"set data(maxIW) 1\n"
|
7390 |
|
|
"set data(maxIH) 1\n"
|
7391 |
|
|
"set data(maxTW) 1\n"
|
7392 |
|
|
"set data(maxTH) 1\n"
|
7393 |
|
|
"set data(numItems) 0\n"
|
7394 |
|
|
"set data(curItem) {}\n"
|
7395 |
|
|
"set data(noScroll) 1\n"
|
7396 |
|
|
"$data(sbar) set 0.0 1.0\n"
|
7397 |
|
|
"$data(canvas) xview moveto 0\n"
|
7398 |
|
|
"}\n"
|
7399 |
|
|
"proc tkIconList_Add {w image text} {\n"
|
7400 |
|
|
"upvar #0 $w data\n"
|
7401 |
|
|
"upvar #0 $w:itemList itemList\n"
|
7402 |
|
|
"upvar #0 $w:textList textList\n"
|
7403 |
|
|
"set iTag [$data(canvas) create image 0 0 -image $image -anchor nw]\n"
|
7404 |
|
|
"set tTag [$data(canvas) create text 0 0 -text $text -anchor nw \\\n"
|
7405 |
|
|
"\011-font $data(font)]\n"
|
7406 |
|
|
"set rTag [$data(canvas) create rect 0 0 0 0 -fill \"\" -outline \"\"]\n"
|
7407 |
|
|
"set b [$data(canvas) bbox $iTag]\n"
|
7408 |
|
|
"set iW [expr {[lindex $b 2]-[lindex $b 0]}]\n"
|
7409 |
|
|
"set iH [expr {[lindex $b 3]-[lindex $b 1]}]\n"
|
7410 |
|
|
"if {$data(maxIW) < $iW} {\n"
|
7411 |
|
|
"set data(maxIW) $iW\n"
|
7412 |
|
|
"}\n"
|
7413 |
|
|
"if {$data(maxIH) < $iH} {\n"
|
7414 |
|
|
"set data(maxIH) $iH\n"
|
7415 |
|
|
"}\n"
|
7416 |
|
|
"set b [$data(canvas) bbox $tTag]\n"
|
7417 |
|
|
"set tW [expr {[lindex $b 2]-[lindex $b 0]}]\n"
|
7418 |
|
|
"set tH [expr {[lindex $b 3]-[lindex $b 1]}]\n"
|
7419 |
|
|
"if {$data(maxTW) < $tW} {\n"
|
7420 |
|
|
"set data(maxTW) $tW\n"
|
7421 |
|
|
"}\n"
|
7422 |
|
|
"if {$data(maxTH) < $tH} {\n"
|
7423 |
|
|
"set data(maxTH) $tH\n"
|
7424 |
|
|
"}\n"
|
7425 |
|
|
"lappend data(list) [list $iTag $tTag $rTag $iW $iH $tW $tH $data(numItems)]\n"
|
7426 |
|
|
"set itemList($rTag) [list $iTag $tTag $text $data(numItems)]\n"
|
7427 |
|
|
"set textList($data(numItems)) [string tolower $text]\n"
|
7428 |
|
|
"incr data(numItems)\n"
|
7429 |
|
|
"}\n"
|
7430 |
|
|
"proc tkIconList_Arrange {w} {\n"
|
7431 |
|
|
"upvar #0 $w data\n"
|
7432 |
|
|
"if {![info exists data(list)]} {\n"
|
7433 |
|
|
"if {[info exists data(canvas)] && [winfo exists $data(canvas)]} {\n"
|
7434 |
|
|
"set data(noScroll) 1\n"
|
7435 |
|
|
"$data(sbar) config -command \"\"\n"
|
7436 |
|
|
"}\n"
|
7437 |
|
|
"return\n"
|
7438 |
|
|
"}\n"
|
7439 |
|
|
"set W [winfo width $data(canvas)]\n"
|
7440 |
|
|
"set H [winfo height $data(canvas)]\n"
|
7441 |
|
|
"set pad [expr {[$data(canvas) cget -highlightthickness] + \\\n"
|
7442 |
|
|
"\011 [$data(canvas) cget -bd]}]\n"
|
7443 |
|
|
"if {$pad < 2} {\n"
|
7444 |
|
|
"set pad 2\n"
|
7445 |
|
|
"}\n"
|
7446 |
|
|
"incr W -[expr {$pad*2}]\n"
|
7447 |
|
|
"incr H -[expr {$pad*2}]\n"
|
7448 |
|
|
"set dx [expr {$data(maxIW) + $data(maxTW) + 8}]\n"
|
7449 |
|
|
"if {$data(maxTH) > $data(maxIH)} {\n"
|
7450 |
|
|
"set dy $data(maxTH)\n"
|
7451 |
|
|
"} else {\n"
|
7452 |
|
|
"set dy $data(maxIH)\n"
|
7453 |
|
|
"}\n"
|
7454 |
|
|
"incr dy 2\n"
|
7455 |
|
|
"set shift [expr {$data(maxIW) + 4}]\n"
|
7456 |
|
|
"set x [expr {$pad * 2}]\n"
|
7457 |
|
|
"set y [expr {$pad * 1}] ; # Why * 1 ?\n"
|
7458 |
|
|
"set usedColumn 0\n"
|
7459 |
|
|
"foreach sublist $data(list) {\n"
|
7460 |
|
|
"set usedColumn 1\n"
|
7461 |
|
|
"set iTag [lindex $sublist 0]\n"
|
7462 |
|
|
"set tTag [lindex $sublist 1]\n"
|
7463 |
|
|
"set rTag [lindex $sublist 2]\n"
|
7464 |
|
|
"set iW [lindex $sublist 3]\n"
|
7465 |
|
|
"set iH [lindex $sublist 4]\n"
|
7466 |
|
|
"set tW [lindex $sublist 5]\n"
|
7467 |
|
|
"set tH [lindex $sublist 6]\n"
|
7468 |
|
|
"set i_dy [expr {($dy - $iH)/2}]\n"
|
7469 |
|
|
"set t_dy [expr {($dy - $tH)/2}]\n"
|
7470 |
|
|
"$data(canvas) coords $iTag $x [expr {$y + $i_dy}]\n"
|
7471 |
|
|
"$data(canvas) coords $tTag [expr {$x + $shift}] [expr {$y + $t_dy}]\n"
|
7472 |
|
|
"$data(canvas) coords $tTag [expr {$x + $shift}] [expr {$y + $t_dy}]\n"
|
7473 |
|
|
"$data(canvas) coords $rTag $x $y [expr {$x+$dx}] [expr {$y+$dy}]\n"
|
7474 |
|
|
"incr y $dy\n"
|
7475 |
|
|
"if {($y + $dy) > $H} {\n"
|
7476 |
|
|
"set y [expr {$pad * 1}] ; # *1 ?\n"
|
7477 |
|
|
"incr x $dx\n"
|
7478 |
|
|
"set usedColumn 0\n"
|
7479 |
|
|
"}\n"
|
7480 |
|
|
"}\n"
|
7481 |
|
|
"if {$usedColumn} {\n"
|
7482 |
|
|
"set sW [expr {$x + $dx}]\n"
|
7483 |
|
|
"} else {\n"
|
7484 |
|
|
"set sW $x\n"
|
7485 |
|
|
"}\n"
|
7486 |
|
|
"if {$sW < $W} {\n"
|
7487 |
|
|
"$data(canvas) config -scrollregion [list $pad $pad $sW $H]\n"
|
7488 |
|
|
"$data(sbar) config -command \"\"\n"
|
7489 |
|
|
"$data(canvas) xview moveto 0\n"
|
7490 |
|
|
"set data(noScroll) 1\n"
|
7491 |
|
|
"} else {\n"
|
7492 |
|
|
"$data(canvas) config -scrollregion [list $pad $pad $sW $H]\n"
|
7493 |
|
|
"$data(sbar) config -command [list $data(canvas) xview]\n"
|
7494 |
|
|
"set data(noScroll) 0\n"
|
7495 |
|
|
"}\n"
|
7496 |
|
|
"set data(itemsPerColumn) [expr {($H-$pad)/$dy}]\n"
|
7497 |
|
|
"if {$data(itemsPerColumn) < 1} {\n"
|
7498 |
|
|
"set data(itemsPerColumn) 1\n"
|
7499 |
|
|
"}\n"
|
7500 |
|
|
"if {$data(curItem) != \"\"} {\n"
|
7501 |
|
|
"tkIconList_Select $w [lindex [lindex $data(list) $data(curItem)] 2] 0\n"
|
7502 |
|
|
"}\n"
|
7503 |
|
|
"}\n"
|
7504 |
|
|
"proc tkIconList_Invoke {w} {\n"
|
7505 |
|
|
"upvar #0 $w data\n"
|
7506 |
|
|
"if {$data(-command) != \"\" && [info exists data(selected)]} {\n"
|
7507 |
|
|
"uplevel #0 $data(-command)\n"
|
7508 |
|
|
"}\n"
|
7509 |
|
|
"}\n"
|
7510 |
|
|
"proc tkIconList_See {w rTag} {\n"
|
7511 |
|
|
"upvar #0 $w data\n"
|
7512 |
|
|
"upvar #0 $w:itemList itemList\n"
|
7513 |
|
|
"if {$data(noScroll)} {\n"
|
7514 |
|
|
"return\n"
|
7515 |
|
|
"}\n"
|
7516 |
|
|
"set sRegion [$data(canvas) cget -scrollregion]\n"
|
7517 |
|
|
"if {[string equal $sRegion {}]} {\n"
|
7518 |
|
|
"return\n"
|
7519 |
|
|
"}\n"
|
7520 |
|
|
"if {![info exists itemList($rTag)]} {\n"
|
7521 |
|
|
"return\n"
|
7522 |
|
|
"}\n"
|
7523 |
|
|
"set bbox [$data(canvas) bbox $rTag]\n"
|
7524 |
|
|
"set pad [expr {[$data(canvas) cget -highlightthickness] + \\\n"
|
7525 |
|
|
"\011 [$data(canvas) cget -bd]}]\n"
|
7526 |
|
|
"set x1 [lindex $bbox 0]\n"
|
7527 |
|
|
"set x2 [lindex $bbox 2]\n"
|
7528 |
|
|
"incr x1 -[expr {$pad * 2}]\n"
|
7529 |
|
|
"incr x2 -[expr {$pad * 1}] ; # *1 ?\n"
|
7530 |
|
|
"set cW [expr {[winfo width $data(canvas)] - $pad*2}]\n"
|
7531 |
|
|
"set scrollW [expr {[lindex $sRegion 2]-[lindex $sRegion 0]+1}]\n"
|
7532 |
|
|
"set dispX [expr {int([lindex [$data(canvas) xview] 0]*$scrollW)}]\n"
|
7533 |
|
|
"set oldDispX $dispX\n"
|
7534 |
|
|
"if {($x2 - $dispX) >= $cW} {\n"
|
7535 |
|
|
"set dispX [expr {$x2 - $cW}]\n"
|
7536 |
|
|
"}\n"
|
7537 |
|
|
"if {($x1 - $dispX) < 0} {\n"
|
7538 |
|
|
"set dispX $x1\n"
|
7539 |
|
|
"}\n"
|
7540 |
|
|
"if {$oldDispX != $dispX} {\n"
|
7541 |
|
|
"set fraction [expr {double($dispX)/double($scrollW)}]\n"
|
7542 |
|
|
"$data(canvas) xview moveto $fraction\n"
|
7543 |
|
|
"}\n"
|
7544 |
|
|
"}\n"
|
7545 |
|
|
"proc tkIconList_SelectAtXY {w x y} {\n"
|
7546 |
|
|
"upvar #0 $w data\n"
|
7547 |
|
|
"tkIconList_Select $w [$data(canvas) find closest \\\n"
|
7548 |
|
|
"\011 [$data(canvas) canvasx $x] [$data(canvas) canvasy $y]]\n"
|
7549 |
|
|
"}\n"
|
7550 |
|
|
"proc tkIconList_Select {w rTag {callBrowse 1}} {\n"
|
7551 |
|
|
"upvar #0 $w data\n"
|
7552 |
|
|
"upvar #0 $w:itemList itemList\n"
|
7553 |
|
|
"if {![info exists itemList($rTag)]} {\n"
|
7554 |
|
|
"return\n"
|
7555 |
|
|
"}\n"
|
7556 |
|
|
"set iTag [lindex $itemList($rTag) 0]\n"
|
7557 |
|
|
"set tTag [lindex $itemList($rTag) 1]\n"
|
7558 |
|
|
"set text [lindex $itemList($rTag) 2]\n"
|
7559 |
|
|
"set serial [lindex $itemList($rTag) 3]\n"
|
7560 |
|
|
"if {![info exists data(rect)]} {\n"
|
7561 |
|
|
"set data(rect) [$data(canvas) create rect 0 0 0 0 \\\n"
|
7562 |
|
|
"\011\011-fill #a0a0ff -outline #a0a0ff]\n"
|
7563 |
|
|
"}\n"
|
7564 |
|
|
"$data(canvas) lower $data(rect)\n"
|
7565 |
|
|
"set bbox [$data(canvas) bbox $tTag]\n"
|
7566 |
|
|
"eval [list $data(canvas) coords $data(rect)] $bbox\n"
|
7567 |
|
|
"set data(curItem) $serial\n"
|
7568 |
|
|
"set data(selected) $text\n"
|
7569 |
|
|
"if {$callBrowse && $data(-browsecmd) != \"\"} {\n"
|
7570 |
|
|
"eval $data(-browsecmd) [list $text]\n"
|
7571 |
|
|
"}\n"
|
7572 |
|
|
"}\n"
|
7573 |
|
|
"proc tkIconList_Unselect {w} {\n"
|
7574 |
|
|
"upvar #0 $w data\n"
|
7575 |
|
|
"if {[info exists data(rect)]} {\n"
|
7576 |
|
|
"$data(canvas) delete $data(rect)\n"
|
7577 |
|
|
"unset data(rect)\n"
|
7578 |
|
|
"}\n"
|
7579 |
|
|
"if {[info exists data(selected)]} {\n"
|
7580 |
|
|
"unset data(selected)\n"
|
7581 |
|
|
"}\n"
|
7582 |
|
|
"#set data(curItem) {}\n"
|
7583 |
|
|
"}\n"
|
7584 |
|
|
"proc tkIconList_Get {w} {\n"
|
7585 |
|
|
"upvar #0 $w data\n"
|
7586 |
|
|
"if {[info exists data(selected)]} {\n"
|
7587 |
|
|
"return $data(selected)\n"
|
7588 |
|
|
"} else {\n"
|
7589 |
|
|
"return \"\"\n"
|
7590 |
|
|
"}\n"
|
7591 |
|
|
"}\n"
|
7592 |
|
|
"proc tkIconList_Btn1 {w x y} {\n"
|
7593 |
|
|
"upvar #0 $w data\n"
|
7594 |
|
|
"focus $data(canvas)\n"
|
7595 |
|
|
"tkIconList_SelectAtXY $w $x $y\n"
|
7596 |
|
|
"}\n"
|
7597 |
|
|
"proc tkIconList_Motion1 {w x y} {\n"
|
7598 |
|
|
"global tkPriv\n"
|
7599 |
|
|
"set tkPriv(x) $x\n"
|
7600 |
|
|
"set tkPriv(y) $y\n"
|
7601 |
|
|
"tkIconList_SelectAtXY $w $x $y\n"
|
7602 |
|
|
"}\n"
|
7603 |
|
|
"proc tkIconList_Double1 {w x y} {\n"
|
7604 |
|
|
"upvar #0 $w data\n"
|
7605 |
|
|
"if {[string compare $data(curItem) {}]} {\n"
|
7606 |
|
|
"tkIconList_Invoke $w\n"
|
7607 |
|
|
"}\n"
|
7608 |
|
|
"}\n"
|
7609 |
|
|
"proc tkIconList_ReturnKey {w} {\n"
|
7610 |
|
|
"tkIconList_Invoke $w\n"
|
7611 |
|
|
"}\n"
|
7612 |
|
|
"proc tkIconList_Leave1 {w x y} {\n"
|
7613 |
|
|
"global tkPriv\n"
|
7614 |
|
|
"set tkPriv(x) $x\n"
|
7615 |
|
|
"set tkPriv(y) $y\n"
|
7616 |
|
|
"tkIconList_AutoScan $w\n"
|
7617 |
|
|
"}\n"
|
7618 |
|
|
"proc tkIconList_FocusIn {w} {\n"
|
7619 |
|
|
"upvar #0 $w data\n"
|
7620 |
|
|
"if {![info exists data(list)]} {\n"
|
7621 |
|
|
"return\n"
|
7622 |
|
|
"}\n"
|
7623 |
|
|
"if {[string compare $data(curItem) {}]} {\n"
|
7624 |
|
|
"tkIconList_Select $w [lindex [lindex $data(list) $data(curItem)] 2] 1\n"
|
7625 |
|
|
"}\n"
|
7626 |
|
|
"}\n"
|
7627 |
|
|
"proc tkIconList_UpDown {w amount} {\n"
|
7628 |
|
|
"upvar #0 $w data\n"
|
7629 |
|
|
"if {![info exists data(list)]} {\n"
|
7630 |
|
|
"return\n"
|
7631 |
|
|
"}\n"
|
7632 |
|
|
"if {[string equal $data(curItem) {}]} {\n"
|
7633 |
|
|
"set rTag [lindex [lindex $data(list) 0] 2]\n"
|
7634 |
|
|
"} else {\n"
|
7635 |
|
|
"set oldRTag [lindex [lindex $data(list) $data(curItem)] 2]\n"
|
7636 |
|
|
"set rTag [lindex [lindex $data(list) [expr {$data(curItem)+$amount}]] 2]\n"
|
7637 |
|
|
"if {[string equal $rTag \"\"]} {\n"
|
7638 |
|
|
"set rTag $oldRTag\n"
|
7639 |
|
|
"}\n"
|
7640 |
|
|
"}\n"
|
7641 |
|
|
"if {[string compare $rTag \"\"]} {\n"
|
7642 |
|
|
"tkIconList_Select $w $rTag\n"
|
7643 |
|
|
"tkIconList_See $w $rTag\n"
|
7644 |
|
|
"}\n"
|
7645 |
|
|
"}\n"
|
7646 |
|
|
"proc tkIconList_LeftRight {w amount} {\n"
|
7647 |
|
|
"upvar #0 $w data\n"
|
7648 |
|
|
"if {![info exists data(list)]} {\n"
|
7649 |
|
|
"return\n"
|
7650 |
|
|
"}\n"
|
7651 |
|
|
"if {[string equal $data(curItem) {}]} {\n"
|
7652 |
|
|
"set rTag [lindex [lindex $data(list) 0] 2]\n"
|
7653 |
|
|
"} else {\n"
|
7654 |
|
|
"set oldRTag [lindex [lindex $data(list) $data(curItem)] 2]\n"
|
7655 |
|
|
"set newItem [expr {$data(curItem)+($amount*$data(itemsPerColumn))}]\n"
|
7656 |
|
|
"set rTag [lindex [lindex $data(list) $newItem] 2]\n"
|
7657 |
|
|
"if {[string equal $rTag \"\"]} {\n"
|
7658 |
|
|
"set rTag $oldRTag\n"
|
7659 |
|
|
"}\n"
|
7660 |
|
|
"}\n"
|
7661 |
|
|
"if {[string compare $rTag \"\"]} {\n"
|
7662 |
|
|
"tkIconList_Select $w $rTag\n"
|
7663 |
|
|
"tkIconList_See $w $rTag\n"
|
7664 |
|
|
"}\n"
|
7665 |
|
|
"}\n"
|
7666 |
|
|
"proc tkIconList_KeyPress {w key} {\n"
|
7667 |
|
|
"global tkPriv\n"
|
7668 |
|
|
"append tkPriv(ILAccel,$w) $key\n"
|
7669 |
|
|
"tkIconList_Goto $w $tkPriv(ILAccel,$w)\n"
|
7670 |
|
|
"catch {\n"
|
7671 |
|
|
"after cancel $tkPriv(ILAccel,$w,afterId)\n"
|
7672 |
|
|
"}\n"
|
7673 |
|
|
"set tkPriv(ILAccel,$w,afterId) [after 500 [list tkIconList_Reset $w]]\n"
|
7674 |
|
|
"}\n"
|
7675 |
|
|
"proc tkIconList_Goto {w text} {\n"
|
7676 |
|
|
"upvar #0 $w data\n"
|
7677 |
|
|
"upvar #0 $w:textList textList\n"
|
7678 |
|
|
"global tkPriv\n"
|
7679 |
|
|
"if {![info exists data(list)]} {\n"
|
7680 |
|
|
"return\n"
|
7681 |
|
|
"}\n"
|
7682 |
|
|
"if {[string equal {} $text]} {\n"
|
7683 |
|
|
"return\n"
|
7684 |
|
|
"}\n"
|
7685 |
|
|
"if {$data(curItem) == \"\" || $data(curItem) == 0} {\n"
|
7686 |
|
|
"set start 0\n"
|
7687 |
|
|
"} else {\n"
|
7688 |
|
|
"set start $data(curItem)\n"
|
7689 |
|
|
"}\n"
|
7690 |
|
|
"set text [string tolower $text]\n"
|
7691 |
|
|
"set theIndex -1\n"
|
7692 |
|
|
"set less 0\n"
|
7693 |
|
|
"set len [string length $text]\n"
|
7694 |
|
|
"set len0 [expr {$len-1}]\n"
|
7695 |
|
|
"set i $start\n"
|
7696 |
|
|
"while {1} {\n"
|
7697 |
|
|
"set sub [string range $textList($i) 0 $len0]\n"
|
7698 |
|
|
"if {[string equal $text $sub]} {\n"
|
7699 |
|
|
"set theIndex $i\n"
|
7700 |
|
|
"break\n"
|
7701 |
|
|
"}\n"
|
7702 |
|
|
"incr i\n"
|
7703 |
|
|
"if {$i == $data(numItems)} {\n"
|
7704 |
|
|
"set i 0\n"
|
7705 |
|
|
"}\n"
|
7706 |
|
|
"if {$i == $start} {\n"
|
7707 |
|
|
"break\n"
|
7708 |
|
|
"}\n"
|
7709 |
|
|
"}\n"
|
7710 |
|
|
"if {$theIndex > -1} {\n"
|
7711 |
|
|
"set rTag [lindex [lindex $data(list) $theIndex] 2]\n"
|
7712 |
|
|
"tkIconList_Select $w $rTag\n"
|
7713 |
|
|
"tkIconList_See $w $rTag\n"
|
7714 |
|
|
"}\n"
|
7715 |
|
|
"}\n"
|
7716 |
|
|
"proc tkIconList_Reset {w} {\n"
|
7717 |
|
|
"global tkPriv\n"
|
7718 |
|
|
"catch {unset tkPriv(ILAccel,$w)}\n"
|
7719 |
|
|
"}\n"
|
7720 |
|
|
"namespace eval ::tk::dialog {}\n"
|
7721 |
|
|
"namespace eval ::tk::dialog::file {}\n"
|
7722 |
|
|
"proc ::tk::dialog::file::tkFDialog {type args} {\n"
|
7723 |
|
|
"global tkPriv\n"
|
7724 |
|
|
"set dataName __tk_filedialog\n"
|
7725 |
|
|
"upvar ::tk::dialog::file::$dataName data\n"
|
7726 |
|
|
"::tk::dialog::file::Config $dataName $type $args\n"
|
7727 |
|
|
"if {[string equal $data(-parent) .]} {\n"
|
7728 |
|
|
"set w .$dataName\n"
|
7729 |
|
|
"} else {\n"
|
7730 |
|
|
"set w $data(-parent).$dataName\n"
|
7731 |
|
|
"}\n"
|
7732 |
|
|
"if {![winfo exists $w]} {\n"
|
7733 |
|
|
"::tk::dialog::file::Create $w TkFDialog\n"
|
7734 |
|
|
"} elseif {[string compare [winfo class $w] TkFDialog]} {\n"
|
7735 |
|
|
"destroy $w\n"
|
7736 |
|
|
"::tk::dialog::file::Create $w TkFDialog\n"
|
7737 |
|
|
"} else {\n"
|
7738 |
|
|
"set data(dirMenuBtn) $w.f1.menu\n"
|
7739 |
|
|
"set data(dirMenu) $w.f1.menu.menu\n"
|
7740 |
|
|
"set data(upBtn) $w.f1.up\n"
|
7741 |
|
|
"set data(icons) $w.icons\n"
|
7742 |
|
|
"set data(ent) $w.f2.ent\n"
|
7743 |
|
|
"set data(typeMenuLab) $w.f3.lab\n"
|
7744 |
|
|
"set data(typeMenuBtn) $w.f3.menu\n"
|
7745 |
|
|
"set data(typeMenu) $data(typeMenuBtn).m\n"
|
7746 |
|
|
"set data(okBtn) $w.f2.ok\n"
|
7747 |
|
|
"set data(cancelBtn) $w.f3.cancel\n"
|
7748 |
|
|
"}\n"
|
7749 |
|
|
"wm transient $w $data(-parent)\n"
|
7750 |
|
|
"trace variable data(selectPath) w \"::tk::dialog::file::SetPath $w\"\n"
|
7751 |
|
|
"$data(dirMenuBtn) configure \\\n"
|
7752 |
|
|
"\011 -textvariable ::tk::dialog::file::${dataName}(selectPath)\n"
|
7753 |
|
|
"if {[llength $data(-filetypes)]} {\n"
|
7754 |
|
|
"$data(typeMenu) delete 0 end\n"
|
7755 |
|
|
"foreach type $data(-filetypes) {\n"
|
7756 |
|
|
"set title [lindex $type 0]\n"
|
7757 |
|
|
"set filter [lindex $type 1]\n"
|
7758 |
|
|
"$data(typeMenu) add command -label $title \\\n"
|
7759 |
|
|
"\011\011-command [list ::tk::dialog::file::SetFilter $w $type]\n"
|
7760 |
|
|
"}\n"
|
7761 |
|
|
"::tk::dialog::file::SetFilter $w [lindex $data(-filetypes) 0]\n"
|
7762 |
|
|
"$data(typeMenuBtn) config -state normal\n"
|
7763 |
|
|
"$data(typeMenuLab) config -state normal\n"
|
7764 |
|
|
"} else {\n"
|
7765 |
|
|
"set data(filter) \"*\"\n"
|
7766 |
|
|
"$data(typeMenuBtn) config -state disabled -takefocus 0\n"
|
7767 |
|
|
"$data(typeMenuLab) config -state disabled\n"
|
7768 |
|
|
"}\n"
|
7769 |
|
|
"::tk::dialog::file::UpdateWhenIdle $w\n"
|
7770 |
|
|
"::tk::PlaceWindow $w widget $data(-parent)\n"
|
7771 |
|
|
"wm title $w $data(-title)\n"
|
7772 |
|
|
"::tk::SetFocusGrab $w $data(ent)\n"
|
7773 |
|
|
"$data(ent) delete 0 end\n"
|
7774 |
|
|
"$data(ent) insert 0 $data(selectFile)\n"
|
7775 |
|
|
"$data(ent) selection range 0 end\n"
|
7776 |
|
|
"$data(ent) icursor end\n"
|
7777 |
|
|
"tkwait variable tkPriv(selectFilePath)\n"
|
7778 |
|
|
"::tk::RestoreFocusGrab $w $data(ent) withdraw\n"
|
7779 |
|
|
"foreach trace [trace vinfo data(selectPath)] {\n"
|
7780 |
|
|
"trace vdelete data(selectPath) [lindex $trace 0] [lindex $trace 1]\n"
|
7781 |
|
|
"}\n"
|
7782 |
|
|
"$data(dirMenuBtn) configure -textvariable {}\n"
|
7783 |
|
|
"return $tkPriv(selectFilePath)\n"
|
7784 |
|
|
"}\n"
|
7785 |
|
|
"proc ::tk::dialog::file::Config {dataName type argList} {\n"
|
7786 |
|
|
"upvar ::tk::dialog::file::$dataName data\n"
|
7787 |
|
|
"set data(type) $type\n"
|
7788 |
|
|
"foreach trace [trace vinfo data(selectPath)] {\n"
|
7789 |
|
|
"trace vdelete data(selectPath) [lindex $trace 0] [lindex $trace 1]\n"
|
7790 |
|
|
"}\n"
|
7791 |
|
|
"set specs {\n"
|
7792 |
|
|
"{-defaultextension \"\" \"\" \"\"}\n"
|
7793 |
|
|
"{-filetypes \"\" \"\" \"\"}\n"
|
7794 |
|
|
"{-initialdir \"\" \"\" \"\"}\n"
|
7795 |
|
|
"{-initialfile \"\" \"\" \"\"}\n"
|
7796 |
|
|
"{-parent \"\" \"\" \".\"}\n"
|
7797 |
|
|
"{-title \"\" \"\" \"\"}\n"
|
7798 |
|
|
"}\n"
|
7799 |
|
|
"if {![info exists data(selectPath)]} {\n"
|
7800 |
|
|
"set data(selectPath) [pwd]\n"
|
7801 |
|
|
"set data(selectFile) \"\"\n"
|
7802 |
|
|
"}\n"
|
7803 |
|
|
"tclParseConfigSpec ::tk::dialog::file::$dataName $specs \"\" $argList\n"
|
7804 |
|
|
"if {$data(-title) == \"\"} {\n"
|
7805 |
|
|
"if {[string equal $type \"open\"]} {\n"
|
7806 |
|
|
"set data(-title) \"Open\"\n"
|
7807 |
|
|
"} else {\n"
|
7808 |
|
|
"set data(-title) \"Save As\"\n"
|
7809 |
|
|
"}\n"
|
7810 |
|
|
"}\n"
|
7811 |
|
|
"if {$data(-initialdir) != \"\"} {\n"
|
7812 |
|
|
"if {[file isdirectory $data(-initialdir)]} {\n"
|
7813 |
|
|
"set old [pwd]\n"
|
7814 |
|
|
"cd $data(-initialdir)\n"
|
7815 |
|
|
"set data(selectPath) [pwd]\n"
|
7816 |
|
|
"cd $old\n"
|
7817 |
|
|
"} else {\n"
|
7818 |
|
|
"set data(selectPath) [pwd]\n"
|
7819 |
|
|
"}\n"
|
7820 |
|
|
"}\n"
|
7821 |
|
|
"set data(selectFile) $data(-initialfile)\n"
|
7822 |
|
|
"set data(-filetypes) [tkFDGetFileTypes $data(-filetypes)]\n"
|
7823 |
|
|
"if {![winfo exists $data(-parent)]} {\n"
|
7824 |
|
|
"error \"bad window path name \\\"$data(-parent)\\\"\"\n"
|
7825 |
|
|
"}\n"
|
7826 |
|
|
"}\n"
|
7827 |
|
|
"proc ::tk::dialog::file::Create {w class} {\n"
|
7828 |
|
|
"set dataName [lindex [split $w .] end]\n"
|
7829 |
|
|
"upvar ::tk::dialog::file::$dataName data\n"
|
7830 |
|
|
"global tk_library tkPriv\n"
|
7831 |
|
|
"toplevel $w -class $class\n"
|
7832 |
|
|
"set f1 [frame $w.f1]\n"
|
7833 |
|
|
"label $f1.lab -text \"Directory:\" -under 0\n"
|
7834 |
|
|
"set data(dirMenuBtn) $f1.menu\n"
|
7835 |
|
|
"set data(dirMenu) [tk_optionMenu $f1.menu [format %s(selectPath) ::tk::dialog::file::$dataName] \"\"]\n"
|
7836 |
|
|
"set data(upBtn) [button $f1.up]\n"
|
7837 |
|
|
"if {![info exists tkPriv(updirImage)]} {\n"
|
7838 |
|
|
"set tkPriv(updirImage) [image create bitmap -data {\n"
|
7839 |
|
|
"#define updir_width 28\n"
|
7840 |
|
|
"#define updir_height 16\n"
|
7841 |
|
|
"static char updir_bits[] = {\n"
|
7842 |
|
|
"0x00, 0x00, 0x00, 0x00, 0x80, 0x1f, 0x00, 0x00, 0x40, 0x20, 0x00, 0x00,\n"
|
7843 |
|
|
"0x20, 0x40, 0x00, 0x00, 0xf0, 0xff, 0xff, 0x01, 0x10, 0x00, 0x00, 0x01,\n"
|
7844 |
|
|
"0x10, 0x02, 0x00, 0x01, 0x10, 0x07, 0x00, 0x01, 0x90, 0x0f, 0x00, 0x01,\n"
|
7845 |
|
|
"0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01,\n"
|
7846 |
|
|
"0x10, 0xfe, 0x07, 0x01, 0x10, 0x00, 0x00, 0x01, 0x10, 0x00, 0x00, 0x01,\n"
|
7847 |
|
|
"0xf0, 0xff, 0xff, 0x01};}]\n"
|
7848 |
|
|
"}\n"
|
7849 |
|
|
"$data(upBtn) config -image $tkPriv(updirImage)\n"
|
7850 |
|
|
"$f1.menu config -takefocus 1 -highlightthickness 2\n"
|
7851 |
|
|
"pack $data(upBtn) -side right -padx 4 -fill both\n"
|
7852 |
|
|
"pack $f1.lab -side left -padx 4 -fill both\n"
|
7853 |
|
|
"pack $f1.menu -expand yes -fill both -padx 4\n"
|
7854 |
|
|
"if { [string equal $class TkFDialog] } {\n"
|
7855 |
|
|
"set fNameCaption \"File name:\"\n"
|
7856 |
|
|
"set fNameUnder 5\n"
|
7857 |
|
|
"set iconListCommand [list ::tk::dialog::file::OkCmd $w]\n"
|
7858 |
|
|
"} else {\n"
|
7859 |
|
|
"set fNameCaption \"Selection:\"\n"
|
7860 |
|
|
"set fNameUnder 0\n"
|
7861 |
|
|
"set iconListCommand [list ::tk::dialog::file::chooseDir::DblClick $w]\n"
|
7862 |
|
|
"}\n"
|
7863 |
|
|
"set data(icons) [tkIconList $w.icons \\\n"
|
7864 |
|
|
"\011-browsecmd [list ::tk::dialog::file::ListBrowse $w] \\\n"
|
7865 |
|
|
"\011-command $iconListCommand]\n"
|
7866 |
|
|
"set f2 [frame $w.f2 -bd 0]\n"
|
7867 |
|
|
"label $f2.lab -text $fNameCaption -anchor e -width 14 \\\n"
|
7868 |
|
|
"\011 -under $fNameUnder -pady 0\n"
|
7869 |
|
|
"set data(ent) [entry $f2.ent]\n"
|
7870 |
|
|
"global $w.icons\n"
|
7871 |
|
|
"set $w.icons(font) [$data(ent) cget -font]\n"
|
7872 |
|
|
"set f3 [frame $w.f3 -bd 0]\n"
|
7873 |
|
|
"if { [string equal $class TkFDialog] } {\n"
|
7874 |
|
|
"set data(typeMenuLab) [button $f3.lab -text \"Files of type:\" \\\n"
|
7875 |
|
|
"\011\011-anchor e -width 14 -under 9 \\\n"
|
7876 |
|
|
"\011\011-bd [$f2.lab cget -bd] \\\n"
|
7877 |
|
|
"\011\011-highlightthickness [$f2.lab cget -highlightthickness] \\\n"
|
7878 |
|
|
"\011\011-relief [$f2.lab cget -relief] \\\n"
|
7879 |
|
|
"\011\011-padx [$f2.lab cget -padx] \\\n"
|
7880 |
|
|
"\011\011-pady [$f2.lab cget -pady]]\n"
|
7881 |
|
|
"bindtags $data(typeMenuLab) [list $data(typeMenuLab) Label \\\n"
|
7882 |
|
|
"\011\011[winfo toplevel $data(typeMenuLab)] all]\n"
|
7883 |
|
|
"set data(typeMenuBtn) [menubutton $f3.menu -indicatoron 1 \\\n"
|
7884 |
|
|
"\011\011-menu $f3.menu.m]\n"
|
7885 |
|
|
"set data(typeMenu) [menu $data(typeMenuBtn).m -tearoff 0]\n"
|
7886 |
|
|
"$data(typeMenuBtn) config -takefocus 1 -highlightthickness 2 \\\n"
|
7887 |
|
|
"\011\011-relief raised -bd 2 -anchor w\n"
|
7888 |
|
|
"}\n"
|
7889 |
|
|
"set data(okBtn) [button $f2.ok -text OK -under 0 -width 6 \\\n"
|
7890 |
|
|
"\011-default active -pady 3]\n"
|
7891 |
|
|
"set data(cancelBtn) [button $f3.cancel -text Cancel -under 0 -width 6\\\n"
|
7892 |
|
|
"\011-default normal -pady 3]\n"
|
7893 |
|
|
"pack $data(okBtn) -side right -padx 4 -anchor e\n"
|
7894 |
|
|
"pack $f2.lab -side left -padx 4\n"
|
7895 |
|
|
"pack $f2.ent -expand yes -fill x -padx 2 -pady 0\n"
|
7896 |
|
|
"pack $data(cancelBtn) -side right -padx 4 -anchor w\n"
|
7897 |
|
|
"if { [string equal $class TkFDialog] } {\n"
|
7898 |
|
|
"pack $data(typeMenuLab) -side left -padx 4\n"
|
7899 |
|
|
"pack $data(typeMenuBtn) -expand yes -fill x -side right\n"
|
7900 |
|
|
"}\n"
|
7901 |
|
|
"pack $f1 -side top -fill x -pady 4\n"
|
7902 |
|
|
"pack $f3 -side bottom -fill x\n"
|
7903 |
|
|
"pack $f2 -side bottom -fill x\n"
|
7904 |
|
|
"pack $data(icons) -expand yes -fill both -padx 4 -pady 1\n"
|
7905 |
|
|
"wm protocol $w WM_DELETE_WINDOW [list ::tk::dialog::file::CancelCmd $w]\n"
|
7906 |
|
|
"$data(upBtn) config -command [list ::tk::dialog::file::UpDirCmd $w]\n"
|
7907 |
|
|
"$data(cancelBtn) config -command [list ::tk::dialog::file::CancelCmd $w]\n"
|
7908 |
|
|
"bind $w <KeyPress-Escape> [list tkButtonInvoke $data(cancelBtn)]\n"
|
7909 |
|
|
"bind $w <Alt-c> [list tkButtonInvoke $data(cancelBtn)]\n"
|
7910 |
|
|
"bind $w <Alt-d> [list focus $data(dirMenuBtn)]\n"
|
7911 |
|
|
"if { [string equal $class TkFDialog] } {\n"
|
7912 |
|
|
"bind $data(ent) <Return> [list ::tk::dialog::file::ActivateEnt $w]\n"
|
7913 |
|
|
"$data(okBtn) config -command [list ::tk::dialog::file::OkCmd $w]\n"
|
7914 |
|
|
"bind $w <Alt-t> [format {\n"
|
7915 |
|
|
"if {[string equal [%s cget -state] \"normal\"]} {\n"
|
7916 |
|
|
"focus %s\n"
|
7917 |
|
|
"}\n"
|
7918 |
|
|
"} $data(typeMenuBtn) $data(typeMenuBtn)]\n"
|
7919 |
|
|
"bind $w <Alt-n> [list focus $data(ent)]\n"
|
7920 |
|
|
"bind $w <Alt-o> [list ::tk::dialog::file::InvokeBtn $w Open]\n"
|
7921 |
|
|
"bind $w <Alt-s> [list ::tk::dialog::file::InvokeBtn $w Save]\n"
|
7922 |
|
|
"} else {\n"
|
7923 |
|
|
"set okCmd [list ::tk::dialog::file::chooseDir::OkCmd $w]\n"
|
7924 |
|
|
"bind $data(ent) <Return> $okCmd\n"
|
7925 |
|
|
"$data(okBtn) config -command $okCmd\n"
|
7926 |
|
|
"bind $w <Alt-s> [list focus $data(ent)]\n"
|
7927 |
|
|
"bind $w <Alt-o> [list tkButtonInvoke $data(okBtn)]\n"
|
7928 |
|
|
"}\n"
|
7929 |
|
|
"tkFocusGroup_Create $w\n"
|
7930 |
|
|
"tkFocusGroup_BindIn $w $data(ent) [list ::tk::dialog::file::EntFocusIn $w]\n"
|
7931 |
|
|
"tkFocusGroup_BindOut $w $data(ent) [list ::tk::dialog::file::EntFocusOut $w]\n"
|
7932 |
|
|
"}\n"
|
7933 |
|
|
"proc ::tk::dialog::file::UpdateWhenIdle {w} {\n"
|
7934 |
|
|
"upvar ::tk::dialog::file::[winfo name $w] data\n"
|
7935 |
|
|
"if {[info exists data(updateId)]} {\n"
|
7936 |
|
|
"return\n"
|
7937 |
|
|
"} else {\n"
|
7938 |
|
|
"set data(updateId) [after idle [list ::tk::dialog::file::Update $w]]\n"
|
7939 |
|
|
"}\n"
|
7940 |
|
|
"}\n"
|
7941 |
|
|
"proc ::tk::dialog::file::Update {w} {\n"
|
7942 |
|
|
"if {![winfo exists $w]} {\n"
|
7943 |
|
|
"return\n"
|
7944 |
|
|
"}\n"
|
7945 |
|
|
"set class [winfo class $w]\n"
|
7946 |
|
|
"if { [string compare $class TkFDialog] && \\\n"
|
7947 |
|
|
"\011 [string compare $class TkChooseDir] } {\n"
|
7948 |
|
|
"return\n"
|
7949 |
|
|
"}\n"
|
7950 |
|
|
"set dataName [winfo name $w]\n"
|
7951 |
|
|
"upvar ::tk::dialog::file::$dataName data\n"
|
7952 |
|
|
"global tk_library tkPriv\n"
|
7953 |
|
|
"catch {unset data(updateId)}\n"
|
7954 |
|
|
"if {![info exists tkPriv(folderImage)]} {\n"
|
7955 |
|
|
"set tkPriv(folderImage) [image create photo -data {\n"
|
7956 |
|
|
"R0lGODlhEAAMAKEAAAD//wAAAPD/gAAAACH5BAEAAAAALAAAAAAQAAwAAAIghINhyycvVFsB\n"
|
7957 |
|
|
"QtmS3rjaH1Hg141WaT5ouprt2HHcUgAAOw==}]\n"
|
7958 |
|
|
"set tkPriv(fileImage) [image create photo -data {\n"
|
7959 |
|
|
"R0lGODlhDAAMAKEAALLA3AAAAP//8wAAACH5BAEAAAAALAAAAAAMAAwAAAIgRI4Ha+IfWHsO\n"
|
7960 |
|
|
"rSASvJTGhnhcV3EJlo3kh53ltF5nAhQAOw==}]\n"
|
7961 |
|
|
"}\n"
|
7962 |
|
|
"set folder $tkPriv(folderImage)\n"
|
7963 |
|
|
"set file $tkPriv(fileImage)\n"
|
7964 |
|
|
"set appPWD [pwd]\n"
|
7965 |
|
|
"if {[catch {\n"
|
7966 |
|
|
"cd $data(selectPath)\n"
|
7967 |
|
|
"}]} {\n"
|
7968 |
|
|
"tk_messageBox -type ok -parent $w -message \\\n"
|
7969 |
|
|
"\011 \"Cannot change to the directory \\\"$data(selectPath)\\\".\\nPermission denied.\"\\\n"
|
7970 |
|
|
"\011 -icon warning\n"
|
7971 |
|
|
"cd $appPWD\n"
|
7972 |
|
|
"return\n"
|
7973 |
|
|
"}\n"
|
7974 |
|
|
"set entCursor [$data(ent) cget -cursor]\n"
|
7975 |
|
|
"set dlgCursor [$w cget -cursor]\n"
|
7976 |
|
|
"$data(ent) config -cursor watch\n"
|
7977 |
|
|
"$w config -cursor watch\n"
|
7978 |
|
|
"update idletasks\n"
|
7979 |
|
|
"tkIconList_DeleteAll $data(icons)\n"
|
7980 |
|
|
"foreach f [lsort -dictionary [glob -nocomplain .* *]] {\n"
|
7981 |
|
|
"if {[string equal $f .]} {\n"
|
7982 |
|
|
"continue\n"
|
7983 |
|
|
"}\n"
|
7984 |
|
|
"if {[string equal $f ..]} {\n"
|
7985 |
|
|
"continue\n"
|
7986 |
|
|
"}\n"
|
7987 |
|
|
"if {[file isdir ./$f]} {\n"
|
7988 |
|
|
"if {![info exists hasDoneDir($f)]} {\n"
|
7989 |
|
|
"tkIconList_Add $data(icons) $folder $f\n"
|
7990 |
|
|
"set hasDoneDir($f) 1\n"
|
7991 |
|
|
"}\n"
|
7992 |
|
|
"}\n"
|
7993 |
|
|
"}\n"
|
7994 |
|
|
"if { [string equal $class TkFDialog] } {\n"
|
7995 |
|
|
"if {[string equal $data(filter) *]} {\n"
|
7996 |
|
|
"set files [lsort -dictionary \\\n"
|
7997 |
|
|
"\011\011 [glob -nocomplain .* *]]\n"
|
7998 |
|
|
"} else {\n"
|
7999 |
|
|
"set files [lsort -dictionary \\\n"
|
8000 |
|
|
"\011\011 [eval glob -nocomplain $data(filter)]]\n"
|
8001 |
|
|
"}\n"
|
8002 |
|
|
"foreach f $files {\n"
|
8003 |
|
|
"if {![file isdir ./$f]} {\n"
|
8004 |
|
|
"if {![info exists hasDoneFile($f)]} {\n"
|
8005 |
|
|
"tkIconList_Add $data(icons) $file $f\n"
|
8006 |
|
|
"set hasDoneFile($f) 1\n"
|
8007 |
|
|
"}\n"
|
8008 |
|
|
"}\n"
|
8009 |
|
|
"}\n"
|
8010 |
|
|
"}\n"
|
8011 |
|
|
"tkIconList_Arrange $data(icons)\n"
|
8012 |
|
|
"set list \"\"\n"
|
8013 |
|
|
"set dir \"\"\n"
|
8014 |
|
|
"foreach subdir [file split $data(selectPath)] {\n"
|
8015 |
|
|
"set dir [file join $dir $subdir]\n"
|
8016 |
|
|
"lappend list $dir\n"
|
8017 |
|
|
"}\n"
|
8018 |
|
|
"$data(dirMenu) delete 0 end\n"
|
8019 |
|
|
"set var [format %s(selectPath) ::tk::dialog::file::$dataName]\n"
|
8020 |
|
|
"foreach path $list {\n"
|
8021 |
|
|
"$data(dirMenu) add command -label $path -command [list set $var $path]\n"
|
8022 |
|
|
"}\n"
|
8023 |
|
|
"cd $appPWD\n"
|
8024 |
|
|
"if { [string equal $class TkFDialog] } {\n"
|
8025 |
|
|
"if {[string equal $data(type) open]} {\n"
|
8026 |
|
|
"$data(okBtn) config -text \"Open\"\n"
|
8027 |
|
|
"} else {\n"
|
8028 |
|
|
"$data(okBtn) config -text \"Save\"\n"
|
8029 |
|
|
"}\n"
|
8030 |
|
|
"}\n"
|
8031 |
|
|
"$data(ent) config -cursor $entCursor\n"
|
8032 |
|
|
"$w config -cursor $dlgCursor\n"
|
8033 |
|
|
"}\n"
|
8034 |
|
|
"proc ::tk::dialog::file::SetPathSilently {w path} {\n"
|
8035 |
|
|
"upvar ::tk::dialog::file::[winfo name $w] data\n"
|
8036 |
|
|
"trace vdelete data(selectPath) w [list ::tk::dialog::file::SetPath $w]\n"
|
8037 |
|
|
"set data(selectPath) $path\n"
|
8038 |
|
|
"trace variable data(selectPath) w [list ::tk::dialog::file::SetPath $w]\n"
|
8039 |
|
|
"}\n"
|
8040 |
|
|
"proc ::tk::dialog::file::SetPath {w name1 name2 op} {\n"
|
8041 |
|
|
"if {[winfo exists $w]} {\n"
|
8042 |
|
|
"upvar ::tk::dialog::file::[winfo name $w] data\n"
|
8043 |
|
|
"::tk::dialog::file::UpdateWhenIdle $w\n"
|
8044 |
|
|
"if { [string equal [winfo class $w] TkChooseDir] } {\n"
|
8045 |
|
|
"$data(ent) delete 0 end\n"
|
8046 |
|
|
"$data(ent) insert end $data(selectPath)\n"
|
8047 |
|
|
"}\n"
|
8048 |
|
|
"}\n"
|
8049 |
|
|
"}\n"
|
8050 |
|
|
"proc ::tk::dialog::file::SetFilter {w type} {\n"
|
8051 |
|
|
"upvar ::tk::dialog::file::[winfo name $w] data\n"
|
8052 |
|
|
"upvar \\#0 $data(icons) icons\n"
|
8053 |
|
|
"set data(filter) [lindex $type 1]\n"
|
8054 |
|
|
"$data(typeMenuBtn) config -text [lindex $type 0] -indicatoron 1\n"
|
8055 |
|
|
"$icons(sbar) set 0.0 0.0\n"
|
8056 |
|
|
"::tk::dialog::file::UpdateWhenIdle $w\n"
|
8057 |
|
|
"}\n"
|
8058 |
|
|
"proc ::tk::dialog::file::ResolveFile {context text defaultext} {\n"
|
8059 |
|
|
"set appPWD [pwd]\n"
|
8060 |
|
|
"set path [::tk::dialog::file::JoinFile $context $text]\n"
|
8061 |
|
|
"if {![file isdirectory $path] && [string equal [file ext $path] \"\"]} {\n"
|
8062 |
|
|
"set path \"$path$defaultext\"\n"
|
8063 |
|
|
"}\n"
|
8064 |
|
|
"if {[catch {file exists $path}]} {\n"
|
8065 |
|
|
"return [list ERROR $path \"\"]\n"
|
8066 |
|
|
"}\n"
|
8067 |
|
|
"if {[file exists $path]} {\n"
|
8068 |
|
|
"if {[file isdirectory $path]} {\n"
|
8069 |
|
|
"if {[catch {cd $path}]} {\n"
|
8070 |
|
|
"return [list CHDIR $path \"\"]\n"
|
8071 |
|
|
"}\n"
|
8072 |
|
|
"set directory [pwd]\n"
|
8073 |
|
|
"set file \"\"\n"
|
8074 |
|
|
"set flag OK\n"
|
8075 |
|
|
"cd $appPWD\n"
|
8076 |
|
|
"} else {\n"
|
8077 |
|
|
"if {[catch {cd [file dirname $path]}]} {\n"
|
8078 |
|
|
"return [list CHDIR [file dirname $path] \"\"]\n"
|
8079 |
|
|
"}\n"
|
8080 |
|
|
"set directory [pwd]\n"
|
8081 |
|
|
"set file [file tail $path]\n"
|
8082 |
|
|
"set flag OK\n"
|
8083 |
|
|
"cd $appPWD\n"
|
8084 |
|
|
"}\n"
|
8085 |
|
|
"} else {\n"
|
8086 |
|
|
"set dirname [file dirname $path]\n"
|
8087 |
|
|
"if {[file exists $dirname]} {\n"
|
8088 |
|
|
"if {[catch {cd $dirname}]} {\n"
|
8089 |
|
|
"return [list CHDIR $dirname \"\"]\n"
|
8090 |
|
|
"}\n"
|
8091 |
|
|
"set directory [pwd]\n"
|
8092 |
|
|
"set file [file tail $path]\n"
|
8093 |
|
|
"if {[regexp {[*]|[?]} $file]} {\n"
|
8094 |
|
|
"set flag PATTERN\n"
|
8095 |
|
|
"} else {\n"
|
8096 |
|
|
"set flag FILE\n"
|
8097 |
|
|
"}\n"
|
8098 |
|
|
"cd $appPWD\n"
|
8099 |
|
|
"} else {\n"
|
8100 |
|
|
"set directory $dirname\n"
|
8101 |
|
|
"set file [file tail $path]\n"
|
8102 |
|
|
"set flag PATH\n"
|
8103 |
|
|
"}\n"
|
8104 |
|
|
"}\n"
|
8105 |
|
|
"return [list $flag $directory $file]\n"
|
8106 |
|
|
"}\n"
|
8107 |
|
|
"proc ::tk::dialog::file::EntFocusIn {w} {\n"
|
8108 |
|
|
"upvar ::tk::dialog::file::[winfo name $w] data\n"
|
8109 |
|
|
"if {[string compare [$data(ent) get] \"\"]} {\n"
|
8110 |
|
|
"$data(ent) selection range 0 end\n"
|
8111 |
|
|
"$data(ent) icursor end\n"
|
8112 |
|
|
"} else {\n"
|
8113 |
|
|
"$data(ent) selection clear\n"
|
8114 |
|
|
"}\n"
|
8115 |
|
|
"tkIconList_Unselect $data(icons)\n"
|
8116 |
|
|
"if { [string equal [winfo class $w] TkFDialog] } {\n"
|
8117 |
|
|
"if {[string equal $data(type) open]} {\n"
|
8118 |
|
|
"$data(okBtn) config -text \"Open\"\n"
|
8119 |
|
|
"} else {\n"
|
8120 |
|
|
"$data(okBtn) config -text \"Save\"\n"
|
8121 |
|
|
"}\n"
|
8122 |
|
|
"}\n"
|
8123 |
|
|
"}\n"
|
8124 |
|
|
"proc ::tk::dialog::file::EntFocusOut {w} {\n"
|
8125 |
|
|
"upvar ::tk::dialog::file::[winfo name $w] data\n"
|
8126 |
|
|
"$data(ent) selection clear\n"
|
8127 |
|
|
"}\n"
|
8128 |
|
|
"proc ::tk::dialog::file::ActivateEnt {w} {\n"
|
8129 |
|
|
"upvar ::tk::dialog::file::[winfo name $w] data\n"
|
8130 |
|
|
"set text [string trim [$data(ent) get]]\n"
|
8131 |
|
|
"set list [::tk::dialog::file::ResolveFile $data(selectPath) $text \\\n"
|
8132 |
|
|
"\011\011 $data(-defaultextension)]\n"
|
8133 |
|
|
"set flag [lindex $list 0]\n"
|
8134 |
|
|
"set path [lindex $list 1]\n"
|
8135 |
|
|
"set file [lindex $list 2]\n"
|
8136 |
|
|
"switch -- $flag {\n"
|
8137 |
|
|
"OK {\n"
|
8138 |
|
|
"if {[string equal $file \"\"]} {\n"
|
8139 |
|
|
"set data(selectPath) $path\n"
|
8140 |
|
|
"$data(ent) delete 0 end\n"
|
8141 |
|
|
"} else {\n"
|
8142 |
|
|
"::tk::dialog::file::SetPathSilently $w $path\n"
|
8143 |
|
|
"set data(selectFile) $file\n"
|
8144 |
|
|
"::tk::dialog::file::Done $w\n"
|
8145 |
|
|
"}\n"
|
8146 |
|
|
"}\n"
|
8147 |
|
|
"PATTERN {\n"
|
8148 |
|
|
"set data(selectPath) $path\n"
|
8149 |
|
|
"set data(filter) $file\n"
|
8150 |
|
|
"}\n"
|
8151 |
|
|
"FILE {\n"
|
8152 |
|
|
"if {[string equal $data(type) open]} {\n"
|
8153 |
|
|
"tk_messageBox -icon warning -type ok -parent $w \\\n"
|
8154 |
|
|
"\011\011 -message \"File \\\"[file join $path $file]\\\" does not exist.\"\n"
|
8155 |
|
|
"$data(ent) selection range 0 end\n"
|
8156 |
|
|
"$data(ent) icursor end\n"
|
8157 |
|
|
"} else {\n"
|
8158 |
|
|
"::tk::dialog::file::SetPathSilently $w $path\n"
|
8159 |
|
|
"set data(selectFile) $file\n"
|
8160 |
|
|
"::tk::dialog::file::Done $w\n"
|
8161 |
|
|
"}\n"
|
8162 |
|
|
"}\n"
|
8163 |
|
|
"PATH {\n"
|
8164 |
|
|
"tk_messageBox -icon warning -type ok -parent $w \\\n"
|
8165 |
|
|
"\011\011-message \"Directory \\\"$path\\\" does not exist.\"\n"
|
8166 |
|
|
"$data(ent) selection range 0 end\n"
|
8167 |
|
|
"$data(ent) icursor end\n"
|
8168 |
|
|
"}\n"
|
8169 |
|
|
"CHDIR {\n"
|
8170 |
|
|
"tk_messageBox -type ok -parent $w -message \\\n"
|
8171 |
|
|
"\011 \"Cannot change to the directory \\\"$path\\\".\\nPermission denied.\"\\\n"
|
8172 |
|
|
"\011\011-icon warning\n"
|
8173 |
|
|
"$data(ent) selection range 0 end\n"
|
8174 |
|
|
"$data(ent) icursor end\n"
|
8175 |
|
|
"}\n"
|
8176 |
|
|
"ERROR {\n"
|
8177 |
|
|
"tk_messageBox -type ok -parent $w -message \\\n"
|
8178 |
|
|
"\011 \"Invalid file name \\\"$path\\\".\"\\\n"
|
8179 |
|
|
"\011\011-icon warning\n"
|
8180 |
|
|
"$data(ent) selection range 0 end\n"
|
8181 |
|
|
"$data(ent) icursor end\n"
|
8182 |
|
|
"}\n"
|
8183 |
|
|
"}\n"
|
8184 |
|
|
"}\n"
|
8185 |
|
|
"proc ::tk::dialog::file::InvokeBtn {w key} {\n"
|
8186 |
|
|
"upvar ::tk::dialog::file::[winfo name $w] data\n"
|
8187 |
|
|
"if {[string equal [$data(okBtn) cget -text] $key]} {\n"
|
8188 |
|
|
"tkButtonInvoke $data(okBtn)\n"
|
8189 |
|
|
"}\n"
|
8190 |
|
|
"}\n"
|
8191 |
|
|
"proc ::tk::dialog::file::UpDirCmd {w} {\n"
|
8192 |
|
|
"upvar ::tk::dialog::file::[winfo name $w] data\n"
|
8193 |
|
|
"if {[string compare $data(selectPath) \"/\"]} {\n"
|
8194 |
|
|
"set data(selectPath) [file dirname $data(selectPath)]\n"
|
8195 |
|
|
"}\n"
|
8196 |
|
|
"}\n"
|
8197 |
|
|
"proc ::tk::dialog::file::JoinFile {path file} {\n"
|
8198 |
|
|
"if {[string match {~*} $file] && [file exists $path/$file]} {\n"
|
8199 |
|
|
"return [file join $path ./$file]\n"
|
8200 |
|
|
"} else {\n"
|
8201 |
|
|
"return [file join $path $file]\n"
|
8202 |
|
|
"}\n"
|
8203 |
|
|
"}\n"
|
8204 |
|
|
"proc ::tk::dialog::file::OkCmd {w} {\n"
|
8205 |
|
|
"upvar ::tk::dialog::file::[winfo name $w] data\n"
|
8206 |
|
|
"set text [tkIconList_Get $data(icons)]\n"
|
8207 |
|
|
"if {[string compare $text \"\"]} {\n"
|
8208 |
|
|
"set file [::tk::dialog::file::JoinFile $data(selectPath) $text]\n"
|
8209 |
|
|
"if {[file isdirectory $file]} {\n"
|
8210 |
|
|
"::tk::dialog::file::ListInvoke $w $text\n"
|
8211 |
|
|
"return\n"
|
8212 |
|
|
"}\n"
|
8213 |
|
|
"}\n"
|
8214 |
|
|
"::tk::dialog::file::ActivateEnt $w\n"
|
8215 |
|
|
"}\n"
|
8216 |
|
|
"proc ::tk::dialog::file::CancelCmd {w} {\n"
|
8217 |
|
|
"upvar ::tk::dialog::file::[winfo name $w] data\n"
|
8218 |
|
|
"global tkPriv\n"
|
8219 |
|
|
"set tkPriv(selectFilePath) \"\"\n"
|
8220 |
|
|
"}\n"
|
8221 |
|
|
"proc ::tk::dialog::file::ListBrowse {w text} {\n"
|
8222 |
|
|
"upvar ::tk::dialog::file::[winfo name $w] data\n"
|
8223 |
|
|
"if {[string equal $text \"\"]} {\n"
|
8224 |
|
|
"return\n"
|
8225 |
|
|
"}\n"
|
8226 |
|
|
"set file [::tk::dialog::file::JoinFile $data(selectPath) $text]\n"
|
8227 |
|
|
"if {![file isdirectory $file]} {\n"
|
8228 |
|
|
"$data(ent) delete 0 end\n"
|
8229 |
|
|
"$data(ent) insert 0 $text\n"
|
8230 |
|
|
"if { [string equal [winfo class $w] TkFDialog] } {\n"
|
8231 |
|
|
"if {[string equal $data(type) open]} {\n"
|
8232 |
|
|
"$data(okBtn) config -text \"Open\"\n"
|
8233 |
|
|
"} else {\n"
|
8234 |
|
|
"$data(okBtn) config -text \"Save\"\n"
|
8235 |
|
|
"}\n"
|
8236 |
|
|
"}\n"
|
8237 |
|
|
"} else {\n"
|
8238 |
|
|
"if { [string equal [winfo class $w] TkFDialog] } {\n"
|
8239 |
|
|
"$data(okBtn) config -text \"Open\"\n"
|
8240 |
|
|
"}\n"
|
8241 |
|
|
"}\n"
|
8242 |
|
|
"}\n"
|
8243 |
|
|
"proc ::tk::dialog::file::ListInvoke {w text} {\n"
|
8244 |
|
|
"upvar ::tk::dialog::file::[winfo name $w] data\n"
|
8245 |
|
|
"if {[string equal $text \"\"]} {\n"
|
8246 |
|
|
"return\n"
|
8247 |
|
|
"}\n"
|
8248 |
|
|
"set file [::tk::dialog::file::JoinFile $data(selectPath) $text]\n"
|
8249 |
|
|
"set class [winfo class $w]\n"
|
8250 |
|
|
"if {[string equal $class TkChooseDir] || [file isdirectory $file]} {\n"
|
8251 |
|
|
"set appPWD [pwd]\n"
|
8252 |
|
|
"if {[catch {cd $file}]} {\n"
|
8253 |
|
|
"tk_messageBox -type ok -parent $w -message \\\n"
|
8254 |
|
|
"\011 \"Cannot change to the directory \\\"$file\\\".\\nPermission denied.\"\\\n"
|
8255 |
|
|
"\011\011-icon warning\n"
|
8256 |
|
|
"} else {\n"
|
8257 |
|
|
"cd $appPWD\n"
|
8258 |
|
|
"set data(selectPath) $file\n"
|
8259 |
|
|
"}\n"
|
8260 |
|
|
"} else {\n"
|
8261 |
|
|
"set data(selectFile) $file\n"
|
8262 |
|
|
"::tk::dialog::file::Done $w\n"
|
8263 |
|
|
"}\n"
|
8264 |
|
|
"}\n"
|
8265 |
|
|
"proc ::tk::dialog::file::Done {w {selectFilePath \"\"}} {\n"
|
8266 |
|
|
"upvar ::tk::dialog::file::[winfo name $w] data\n"
|
8267 |
|
|
"global tkPriv\n"
|
8268 |
|
|
"if {[string equal $selectFilePath \"\"]} {\n"
|
8269 |
|
|
"set selectFilePath [::tk::dialog::file::JoinFile $data(selectPath) \\\n"
|
8270 |
|
|
"\011\011$data(selectFile)]\n"
|
8271 |
|
|
"set tkPriv(selectFile) $data(selectFile)\n"
|
8272 |
|
|
"set tkPriv(selectPath) $data(selectPath)\n"
|
8273 |
|
|
"if {[file exists $selectFilePath] && [string equal $data(type) save]} {\n"
|
8274 |
|
|
"set reply [tk_messageBox -icon warning -type yesno\\\n"
|
8275 |
|
|
"\011\011 -parent $w -message \"File\\\n"
|
8276 |
|
|
"\011\011 \\\"$selectFilePath\\\" already exists.\\nDo\\\n"
|
8277 |
|
|
"\011\011 you want to overwrite it?\"]\n"
|
8278 |
|
|
"if {[string equal $reply \"no\"]} {\n"
|
8279 |
|
|
"return\n"
|
8280 |
|
|
"}\n"
|
8281 |
|
|
"}\n"
|
8282 |
|
|
"}\n"
|
8283 |
|
|
"set tkPriv(selectFilePath) $selectFilePath\n"
|
8284 |
|
|
"}\n"
|
8285 |
|
|
;
|
8286 |
|
|
static char Et_zFile30[] =
|
8287 |
|
|
"namespace eval ::tk::dialog {}\n"
|
8288 |
|
|
"namespace eval ::tk::dialog::file {}\n"
|
8289 |
|
|
"proc tkMotifFDialog {type args} {\n"
|
8290 |
|
|
"global tkPriv\n"
|
8291 |
|
|
"set dataName __tk_filedialog\n"
|
8292 |
|
|
"upvar ::tk::dialog::file::$dataName data\n"
|
8293 |
|
|
"set w [tkMotifFDialog_Create $dataName $type $args]\n"
|
8294 |
|
|
"::tk::SetFocusGrab $w $data(sEnt)\n"
|
8295 |
|
|
"$data(sEnt) selection range 0 end\n"
|
8296 |
|
|
"tkwait variable tkPriv(selectFilePath)\n"
|
8297 |
|
|
"::tk::RestoreFocusGrab $w $data(sEnt) withdraw\n"
|
8298 |
|
|
"return $tkPriv(selectFilePath)\n"
|
8299 |
|
|
"}\n"
|
8300 |
|
|
"proc tkMotifFDialog_Create {dataName type argList} {\n"
|
8301 |
|
|
"global tkPriv\n"
|
8302 |
|
|
"upvar ::tk::dialog::file::$dataName data\n"
|
8303 |
|
|
"tkMotifFDialog_Config $dataName $type $argList\n"
|
8304 |
|
|
"if {[string equal $data(-parent) .]} {\n"
|
8305 |
|
|
"set w .$dataName\n"
|
8306 |
|
|
"} else {\n"
|
8307 |
|
|
"set w $data(-parent).$dataName\n"
|
8308 |
|
|
"}\n"
|
8309 |
|
|
"if {![winfo exists $w]} {\n"
|
8310 |
|
|
"tkMotifFDialog_BuildUI $w\n"
|
8311 |
|
|
"} elseif {[string compare [winfo class $w] TkMotifFDialog]} {\n"
|
8312 |
|
|
"destroy $w\n"
|
8313 |
|
|
"tkMotifFDialog_BuildUI $w\n"
|
8314 |
|
|
"} else {\n"
|
8315 |
|
|
"set data(fEnt) $w.top.f1.ent\n"
|
8316 |
|
|
"set data(dList) $w.top.f2.a.l\n"
|
8317 |
|
|
"set data(fList) $w.top.f2.b.l\n"
|
8318 |
|
|
"set data(sEnt) $w.top.f3.ent\n"
|
8319 |
|
|
"set data(okBtn) $w.bot.ok\n"
|
8320 |
|
|
"set data(filterBtn) $w.bot.filter\n"
|
8321 |
|
|
"set data(cancelBtn) $w.bot.cancel\n"
|
8322 |
|
|
"}\n"
|
8323 |
|
|
"wm transient $w $data(-parent)\n"
|
8324 |
|
|
"tkMotifFDialog_Update $w\n"
|
8325 |
|
|
"::tk::PlaceWindow $w\n"
|
8326 |
|
|
"wm title $w $data(-title)\n"
|
8327 |
|
|
"return $w\n"
|
8328 |
|
|
"}\n"
|
8329 |
|
|
"proc tkMotifFDialog_Config {dataName type argList} {\n"
|
8330 |
|
|
"upvar ::tk::dialog::file::$dataName data\n"
|
8331 |
|
|
"set data(type) $type\n"
|
8332 |
|
|
"set specs {\n"
|
8333 |
|
|
"{-defaultextension \"\" \"\" \"\"}\n"
|
8334 |
|
|
"{-filetypes \"\" \"\" \"\"}\n"
|
8335 |
|
|
"{-initialdir \"\" \"\" \"\"}\n"
|
8336 |
|
|
"{-initialfile \"\" \"\" \"\"}\n"
|
8337 |
|
|
"{-parent \"\" \"\" \".\"}\n"
|
8338 |
|
|
"{-title \"\" \"\" \"\"}\n"
|
8339 |
|
|
"}\n"
|
8340 |
|
|
"if {![info exists data(selectPath)]} {\n"
|
8341 |
|
|
"set data(selectPath) [pwd]\n"
|
8342 |
|
|
"set data(selectFile) \"\"\n"
|
8343 |
|
|
"}\n"
|
8344 |
|
|
"tclParseConfigSpec ::tk::dialog::file::$dataName $specs \"\" $argList\n"
|
8345 |
|
|
"if {[string equal $data(-title) \"\"]} {\n"
|
8346 |
|
|
"if {[string equal $type \"open\"]} {\n"
|
8347 |
|
|
"set data(-title) \"Open\"\n"
|
8348 |
|
|
"} else {\n"
|
8349 |
|
|
"set data(-title) \"Save As\"\n"
|
8350 |
|
|
"}\n"
|
8351 |
|
|
"}\n"
|
8352 |
|
|
"if {[string compare $data(-initialdir) \"\"]} {\n"
|
8353 |
|
|
"if {[file isdirectory $data(-initialdir)]} {\n"
|
8354 |
|
|
"set data(selectPath) [glob $data(-initialdir)]\n"
|
8355 |
|
|
"} else {\n"
|
8356 |
|
|
"set data(selectPath) [pwd]\n"
|
8357 |
|
|
"}\n"
|
8358 |
|
|
"set old [pwd]\n"
|
8359 |
|
|
"cd $data(selectPath)\n"
|
8360 |
|
|
"set data(selectPath) [pwd]\n"
|
8361 |
|
|
"cd $old\n"
|
8362 |
|
|
"}\n"
|
8363 |
|
|
"set data(selectFile) $data(-initialfile)\n"
|
8364 |
|
|
"set data(-filetypes) [tkFDGetFileTypes $data(-filetypes)]\n"
|
8365 |
|
|
"if {![info exists data(filter)]} {\n"
|
8366 |
|
|
"set data(filter) *\n"
|
8367 |
|
|
"}\n"
|
8368 |
|
|
"if {![winfo exists $data(-parent)]} {\n"
|
8369 |
|
|
"error \"bad window path name \\\"$data(-parent)\\\"\"\n"
|
8370 |
|
|
"}\n"
|
8371 |
|
|
"}\n"
|
8372 |
|
|
"proc tkMotifFDialog_BuildUI {w} {\n"
|
8373 |
|
|
"set dataName [lindex [split $w .] end]\n"
|
8374 |
|
|
"upvar ::tk::dialog::file::$dataName data\n"
|
8375 |
|
|
"toplevel $w -class TkMotifFDialog\n"
|
8376 |
|
|
"set top [frame $w.top -relief raised -bd 1]\n"
|
8377 |
|
|
"set bot [frame $w.bot -relief raised -bd 1]\n"
|
8378 |
|
|
"pack $w.bot -side bottom -fill x\n"
|
8379 |
|
|
"pack $w.top -side top -expand yes -fill both\n"
|
8380 |
|
|
"set f1 [frame $top.f1]\n"
|
8381 |
|
|
"set f2 [frame $top.f2]\n"
|
8382 |
|
|
"set f3 [frame $top.f3]\n"
|
8383 |
|
|
"pack $f1 -side top -fill x\n"
|
8384 |
|
|
"pack $f3 -side bottom -fill x\n"
|
8385 |
|
|
"pack $f2 -expand yes -fill both\n"
|
8386 |
|
|
"set f2a [frame $f2.a]\n"
|
8387 |
|
|
"set f2b [frame $f2.b]\n"
|
8388 |
|
|
"grid $f2a -row 0 -column 0 -rowspan 1 -columnspan 1 -padx 4 -pady 4 \\\n"
|
8389 |
|
|
"\011-sticky news\n"
|
8390 |
|
|
"grid $f2b -row 0 -column 1 -rowspan 1 -columnspan 1 -padx 4 -pady 4 \\\n"
|
8391 |
|
|
"\011-sticky news\n"
|
8392 |
|
|
"grid rowconfig $f2 0 -minsize 0 -weight 1\n"
|
8393 |
|
|
"grid columnconfig $f2 0 -minsize 0 -weight 1\n"
|
8394 |
|
|
"grid columnconfig $f2 1 -minsize 150 -weight 2\n"
|
8395 |
|
|
"label $f1.lab -text \"Filter:\" -under 3 -anchor w\n"
|
8396 |
|
|
"entry $f1.ent\n"
|
8397 |
|
|
"pack $f1.lab -side top -fill x -padx 6 -pady 4\n"
|
8398 |
|
|
"pack $f1.ent -side top -fill x -padx 4 -pady 0\n"
|
8399 |
|
|
"set data(fEnt) $f1.ent\n"
|
8400 |
|
|
"set data(dList) [tkMotifFDialog_MakeSList $w $f2a Directory: 0 DList]\n"
|
8401 |
|
|
"set data(fList) [tkMotifFDialog_MakeSList $w $f2b Files: 2 FList]\n"
|
8402 |
|
|
"label $f3.lab -text \"Selection:\" -under 0 -anchor w\n"
|
8403 |
|
|
"entry $f3.ent\n"
|
8404 |
|
|
"pack $f3.lab -side top -fill x -padx 6 -pady 0\n"
|
8405 |
|
|
"pack $f3.ent -side top -fill x -padx 4 -pady 4\n"
|
8406 |
|
|
"set data(sEnt) $f3.ent\n"
|
8407 |
|
|
"set data(okBtn) [button $bot.ok -text OK -width 6 -under 0 \\\n"
|
8408 |
|
|
"\011-command [list tkMotifFDialog_OkCmd $w]]\n"
|
8409 |
|
|
"set data(filterBtn) [button $bot.filter -text Filter -width 6 -under 0 \\\n"
|
8410 |
|
|
"\011-command [list tkMotifFDialog_FilterCmd $w]]\n"
|
8411 |
|
|
"set data(cancelBtn) [button $bot.cancel -text Cancel -width 6 -under 0 \\\n"
|
8412 |
|
|
"\011-command [list tkMotifFDialog_CancelCmd $w]]\n"
|
8413 |
|
|
"pack $bot.ok $bot.filter $bot.cancel -padx 10 -pady 10 -expand yes \\\n"
|
8414 |
|
|
"\011-side left\n"
|
8415 |
|
|
"bind $w <Alt-t> [list focus $data(fEnt)]\n"
|
8416 |
|
|
"bind $w <Alt-d> [list focus $data(dList)]\n"
|
8417 |
|
|
"bind $w <Alt-l> [list focus $data(fList)]\n"
|
8418 |
|
|
"bind $w <Alt-s> [list focus $data(sEnt)]\n"
|
8419 |
|
|
"bind $w <Alt-o> [list tkButtonInvoke $bot.ok]\n"
|
8420 |
|
|
"bind $w <Alt-f> [list tkButtonInvoke $bot.filter]\n"
|
8421 |
|
|
"bind $w <Alt-c> [list tkButtonInvoke $bot.cancel]\n"
|
8422 |
|
|
"bind $data(fEnt) <Return> [list tkMotifFDialog_ActivateFEnt $w]\n"
|
8423 |
|
|
"bind $data(sEnt) <Return> [list tkMotifFDialog_ActivateSEnt $w]\n"
|
8424 |
|
|
"wm protocol $w WM_DELETE_WINDOW [list tkMotifFDialog_CancelCmd $w]\n"
|
8425 |
|
|
"}\n"
|
8426 |
|
|
"proc tkMotifFDialog_MakeSList {w f label under cmdPrefix} {\n"
|
8427 |
|
|
"label $f.lab -text $label -under $under -anchor w\n"
|
8428 |
|
|
"listbox $f.l -width 12 -height 5 -selectmode browse -exportselection 0\\\n"
|
8429 |
|
|
"\011-xscrollcommand [list $f.h set]\011-yscrollcommand [list $f.v set]\n"
|
8430 |
|
|
"scrollbar $f.v -orient vertical -takefocus 0 -command [list $f.l yview]\n"
|
8431 |
|
|
"scrollbar $f.h -orient horizontal -takefocus 0 -command [list $f.l xview]\n"
|
8432 |
|
|
"grid $f.lab -row 0 -column 0 -sticky news -rowspan 1 -columnspan 2 \\\n"
|
8433 |
|
|
"\011-padx 2 -pady 2\n"
|
8434 |
|
|
"grid $f.l -row 1 -column 0 -rowspan 1 -columnspan 1 -sticky news\n"
|
8435 |
|
|
"grid $f.v -row 1 -column 1 -rowspan 1 -columnspan 1 -sticky news\n"
|
8436 |
|
|
"grid $f.h -row 2 -column 0 -rowspan 1 -columnspan 1 -sticky news\n"
|
8437 |
|
|
"grid rowconfig $f 0 -weight 0 -minsize 0\n"
|
8438 |
|
|
"grid rowconfig $f 1 -weight 1 -minsize 0\n"
|
8439 |
|
|
"grid columnconfig $f 0 -weight 1 -minsize 0\n"
|
8440 |
|
|
"set list $f.l\n"
|
8441 |
|
|
"bind $list <Up>\011\011[list tkMotifFDialog_Browse$cmdPrefix $w]\n"
|
8442 |
|
|
"bind $list <Down>\011\011[list tkMotifFDialog_Browse$cmdPrefix $w]\n"
|
8443 |
|
|
"bind $list <space>\011\011[list tkMotifFDialog_Browse$cmdPrefix $w]\n"
|
8444 |
|
|
"bind $list <1>\011\011[list tkMotifFDialog_Browse$cmdPrefix $w]\n"
|
8445 |
|
|
"bind $list <B1-Motion>\011[list tkMotifFDialog_Browse$cmdPrefix $w]\n"
|
8446 |
|
|
"bind $list <Double-ButtonRelease-1> \\\n"
|
8447 |
|
|
"\011 [list tkMotifFDialog_Activate$cmdPrefix $w]\n"
|
8448 |
|
|
"bind $list <Return> \"tkMotifFDialog_Browse$cmdPrefix [list $w]; \\\n"
|
8449 |
|
|
"\011 tkMotifFDialog_Activate$cmdPrefix [list $w]\"\n"
|
8450 |
|
|
"bindtags $list [list Listbox $list [winfo toplevel $list] all]\n"
|
8451 |
|
|
"tkListBoxKeyAccel_Set $list\n"
|
8452 |
|
|
"return $f.l\n"
|
8453 |
|
|
"}\n"
|
8454 |
|
|
"proc tkMotifFDialog_InterpFilter {w} {\n"
|
8455 |
|
|
"upvar ::tk::dialog::file::[winfo name $w] data\n"
|
8456 |
|
|
"set text [string trim [$data(fEnt) get]]\n"
|
8457 |
|
|
"set badTilde 0\n"
|
8458 |
|
|
"if {[string equal [string index $text 0] ~]} {\n"
|
8459 |
|
|
"set list [file split $text]\n"
|
8460 |
|
|
"set tilde [lindex $list 0]\n"
|
8461 |
|
|
"if {[catch {set tilde [glob $tilde]}]} {\n"
|
8462 |
|
|
"set badTilde 1\n"
|
8463 |
|
|
"} else {\n"
|
8464 |
|
|
"set text [eval file join [concat $tilde [lrange $list 1 end]]]\n"
|
8465 |
|
|
"}\n"
|
8466 |
|
|
"}\n"
|
8467 |
|
|
"set relative 0\n"
|
8468 |
|
|
"if {[string equal [file pathtype $text] \"relative\"]} {\n"
|
8469 |
|
|
"set relative 1\n"
|
8470 |
|
|
"} elseif {$badTilde} {\n"
|
8471 |
|
|
"set relative 1\011\n"
|
8472 |
|
|
"}\n"
|
8473 |
|
|
"if {$relative} {\n"
|
8474 |
|
|
"tk_messageBox -icon warning -type ok \\\n"
|
8475 |
|
|
"\011 -message \"\\\"$text\\\" must be an absolute pathname\"\n"
|
8476 |
|
|
"$data(fEnt) delete 0 end\n"
|
8477 |
|
|
"$data(fEnt) insert 0 [::tk::dialog::file::JoinFile $data(selectPath) \\\n"
|
8478 |
|
|
"\011\011$data(filter)]\n"
|
8479 |
|
|
"return [list $data(selectPath) $data(filter)]\n"
|
8480 |
|
|
"}\n"
|
8481 |
|
|
"set resolved [::tk::dialog::file::JoinFile [file dirname $text] [file tail $text]]\n"
|
8482 |
|
|
"if {[file isdirectory $resolved]} {\n"
|
8483 |
|
|
"set dir $resolved\n"
|
8484 |
|
|
"set fil $data(filter)\n"
|
8485 |
|
|
"} else {\n"
|
8486 |
|
|
"set dir [file dirname $resolved]\n"
|
8487 |
|
|
"set fil [file tail $resolved]\n"
|
8488 |
|
|
"}\n"
|
8489 |
|
|
"return [list $dir $fil]\n"
|
8490 |
|
|
"}\n"
|
8491 |
|
|
"proc tkMotifFDialog_Update {w} {\n"
|
8492 |
|
|
"upvar ::tk::dialog::file::[winfo name $w] data\n"
|
8493 |
|
|
"$data(fEnt) delete 0 end\n"
|
8494 |
|
|
"$data(fEnt) insert 0 [::tk::dialog::file::JoinFile $data(selectPath) $data(filter)]\n"
|
8495 |
|
|
"$data(sEnt) delete 0 end\n"
|
8496 |
|
|
"$data(sEnt) insert 0 [::tk::dialog::file::JoinFile $data(selectPath) \\\n"
|
8497 |
|
|
"\011 $data(selectFile)]\n"
|
8498 |
|
|
"tkMotifFDialog_LoadFiles $w\n"
|
8499 |
|
|
"}\n"
|
8500 |
|
|
"proc tkMotifFDialog_LoadFiles {w} {\n"
|
8501 |
|
|
"upvar ::tk::dialog::file::[winfo name $w] data\n"
|
8502 |
|
|
"$data(dList) delete 0 end\n"
|
8503 |
|
|
"$data(fList) delete 0 end\n"
|
8504 |
|
|
"set appPWD [pwd]\n"
|
8505 |
|
|
"if {[catch {cd $data(selectPath)}]} {\n"
|
8506 |
|
|
"cd $appPWD\n"
|
8507 |
|
|
"$data(dList) insert end \"..\"\n"
|
8508 |
|
|
"return\n"
|
8509 |
|
|
"}\n"
|
8510 |
|
|
"foreach f [lsort -dictionary [glob -nocomplain .* *]] {\n"
|
8511 |
|
|
"if {[file isdir ./$f]} {\n"
|
8512 |
|
|
"$data(dList) insert end $f\n"
|
8513 |
|
|
"}\n"
|
8514 |
|
|
"}\n"
|
8515 |
|
|
"if {[string equal $data(filter) *]} {\n"
|
8516 |
|
|
"set files [lsort -dictionary [glob -nocomplain .* *]]\n"
|
8517 |
|
|
"} else {\n"
|
8518 |
|
|
"set files [lsort -dictionary \\\n"
|
8519 |
|
|
"\011 [glob -nocomplain $data(filter)]]\n"
|
8520 |
|
|
"}\n"
|
8521 |
|
|
"set top 0\n"
|
8522 |
|
|
"foreach f $files {\n"
|
8523 |
|
|
"if {![file isdir ./$f]} {\n"
|
8524 |
|
|
"regsub {^[.]/} $f \"\" f\n"
|
8525 |
|
|
"$data(fList) insert end $f\n"
|
8526 |
|
|
"if {[string match .* $f]} {\n"
|
8527 |
|
|
"incr top\n"
|
8528 |
|
|
"}\n"
|
8529 |
|
|
"}\n"
|
8530 |
|
|
"}\n"
|
8531 |
|
|
"$data(fList) yview $top\n"
|
8532 |
|
|
"cd $appPWD\n"
|
8533 |
|
|
"}\n"
|
8534 |
|
|
"proc tkMotifFDialog_BrowseDList {w} {\n"
|
8535 |
|
|
"upvar ::tk::dialog::file::[winfo name $w] data\n"
|
8536 |
|
|
"focus $data(dList)\n"
|
8537 |
|
|
"if {[string equal [$data(dList) curselection] \"\"]} {\n"
|
8538 |
|
|
"return\n"
|
8539 |
|
|
"}\n"
|
8540 |
|
|
"set subdir [$data(dList) get [$data(dList) curselection]]\n"
|
8541 |
|
|
"if {[string equal $subdir \"\"]} {\n"
|
8542 |
|
|
"return\n"
|
8543 |
|
|
"}\n"
|
8544 |
|
|
"$data(fList) selection clear 0 end\n"
|
8545 |
|
|
"set list [tkMotifFDialog_InterpFilter $w]\n"
|
8546 |
|
|
"set data(filter) [lindex $list 1]\n"
|
8547 |
|
|
"switch -- $subdir {\n"
|
8548 |
|
|
". {\n"
|
8549 |
|
|
"set newSpec [::tk::dialog::file::JoinFile $data(selectPath) $data(filter)]\n"
|
8550 |
|
|
"}\n"
|
8551 |
|
|
".. {\n"
|
8552 |
|
|
"set newSpec [::tk::dialog::file::JoinFile [file dirname $data(selectPath)] \\\n"
|
8553 |
|
|
"\011\011$data(filter)]\n"
|
8554 |
|
|
"}\n"
|
8555 |
|
|
"default {\n"
|
8556 |
|
|
"set newSpec [::tk::dialog::file::JoinFile [::tk::dialog::file::JoinFile \\\n"
|
8557 |
|
|
"\011\011 $data(selectPath) $subdir] $data(filter)]\n"
|
8558 |
|
|
"}\n"
|
8559 |
|
|
"}\n"
|
8560 |
|
|
"$data(fEnt) delete 0 end\n"
|
8561 |
|
|
"$data(fEnt) insert 0 $newSpec\n"
|
8562 |
|
|
"}\n"
|
8563 |
|
|
"proc tkMotifFDialog_ActivateDList {w} {\n"
|
8564 |
|
|
"upvar ::tk::dialog::file::[winfo name $w] data\n"
|
8565 |
|
|
"if {[string equal [$data(dList) curselection] \"\"]} {\n"
|
8566 |
|
|
"return\n"
|
8567 |
|
|
"}\n"
|
8568 |
|
|
"set subdir [$data(dList) get [$data(dList) curselection]]\n"
|
8569 |
|
|
"if {[string equal $subdir \"\"]} {\n"
|
8570 |
|
|
"return\n"
|
8571 |
|
|
"}\n"
|
8572 |
|
|
"$data(fList) selection clear 0 end\n"
|
8573 |
|
|
"switch -- $subdir {\n"
|
8574 |
|
|
". {\n"
|
8575 |
|
|
"set newDir $data(selectPath)\n"
|
8576 |
|
|
"}\n"
|
8577 |
|
|
".. {\n"
|
8578 |
|
|
"set newDir [file dirname $data(selectPath)]\n"
|
8579 |
|
|
"}\n"
|
8580 |
|
|
"default {\n"
|
8581 |
|
|
"set newDir [::tk::dialog::file::JoinFile $data(selectPath) $subdir]\n"
|
8582 |
|
|
"}\n"
|
8583 |
|
|
"}\n"
|
8584 |
|
|
"set data(selectPath) $newDir\n"
|
8585 |
|
|
"tkMotifFDialog_Update $w\n"
|
8586 |
|
|
"if {[string compare $subdir ..]} {\n"
|
8587 |
|
|
"$data(dList) selection set 0\n"
|
8588 |
|
|
"$data(dList) activate 0\n"
|
8589 |
|
|
"} else {\n"
|
8590 |
|
|
"$data(dList) selection set 1\n"
|
8591 |
|
|
"$data(dList) activate 1\n"
|
8592 |
|
|
"}\n"
|
8593 |
|
|
"}\n"
|
8594 |
|
|
"proc tkMotifFDialog_BrowseFList {w} {\n"
|
8595 |
|
|
"upvar ::tk::dialog::file::[winfo name $w] data\n"
|
8596 |
|
|
"focus $data(fList)\n"
|
8597 |
|
|
"if {[string equal [$data(fList) curselection] \"\"]} {\n"
|
8598 |
|
|
"return\n"
|
8599 |
|
|
"}\n"
|
8600 |
|
|
"set data(selectFile) [$data(fList) get [$data(fList) curselection]]\n"
|
8601 |
|
|
"if {[string equal $data(selectFile) \"\"]} {\n"
|
8602 |
|
|
"return\n"
|
8603 |
|
|
"}\n"
|
8604 |
|
|
"$data(dList) selection clear 0 end\n"
|
8605 |
|
|
"$data(fEnt) delete 0 end\n"
|
8606 |
|
|
"$data(fEnt) insert 0 [::tk::dialog::file::JoinFile $data(selectPath) $data(filter)]\n"
|
8607 |
|
|
"$data(fEnt) xview end\n"
|
8608 |
|
|
"$data(sEnt) delete 0 end\n"
|
8609 |
|
|
"$data(sEnt) insert 0 [::tk::dialog::file::JoinFile $data(selectPath) \\\n"
|
8610 |
|
|
"\011 $data(selectFile)]\n"
|
8611 |
|
|
"$data(sEnt) xview end\n"
|
8612 |
|
|
"}\n"
|
8613 |
|
|
"proc tkMotifFDialog_ActivateFList {w} {\n"
|
8614 |
|
|
"upvar ::tk::dialog::file::[winfo name $w] data\n"
|
8615 |
|
|
"if {[string equal [$data(fList) curselection] \"\"]} {\n"
|
8616 |
|
|
"return\n"
|
8617 |
|
|
"}\n"
|
8618 |
|
|
"set data(selectFile) [$data(fList) get [$data(fList) curselection]]\n"
|
8619 |
|
|
"if {[string equal $data(selectFile) \"\"]} {\n"
|
8620 |
|
|
"return\n"
|
8621 |
|
|
"} else {\n"
|
8622 |
|
|
"tkMotifFDialog_ActivateSEnt $w\n"
|
8623 |
|
|
"}\n"
|
8624 |
|
|
"}\n"
|
8625 |
|
|
"proc tkMotifFDialog_ActivateFEnt {w} {\n"
|
8626 |
|
|
"upvar ::tk::dialog::file::[winfo name $w] data\n"
|
8627 |
|
|
"set list [tkMotifFDialog_InterpFilter $w]\n"
|
8628 |
|
|
"set data(selectPath) [lindex $list 0]\n"
|
8629 |
|
|
"set data(filter) [lindex $list 1]\n"
|
8630 |
|
|
"tkMotifFDialog_Update $w\n"
|
8631 |
|
|
"}\n"
|
8632 |
|
|
"proc tkMotifFDialog_ActivateSEnt {w} {\n"
|
8633 |
|
|
"global tkPriv\n"
|
8634 |
|
|
"upvar ::tk::dialog::file::[winfo name $w] data\n"
|
8635 |
|
|
"set selectFilePath [string trim [$data(sEnt) get]]\n"
|
8636 |
|
|
"set selectFile [file tail $selectFilePath]\n"
|
8637 |
|
|
"set selectPath [file dirname $selectFilePath]\n"
|
8638 |
|
|
"if {[string equal $selectFilePath \"\"]} {\n"
|
8639 |
|
|
"tkMotifFDialog_FilterCmd $w\n"
|
8640 |
|
|
"return\n"
|
8641 |
|
|
"}\n"
|
8642 |
|
|
"if {[file isdirectory $selectFilePath]} {\n"
|
8643 |
|
|
"set data(selectPath) [glob $selectFilePath]\n"
|
8644 |
|
|
"set data(selectFile) \"\"\n"
|
8645 |
|
|
"tkMotifFDialog_Update $w\n"
|
8646 |
|
|
"return\n"
|
8647 |
|
|
"}\n"
|
8648 |
|
|
"if {[string compare [file pathtype $selectFilePath] \"absolute\"]} {\n"
|
8649 |
|
|
"tk_messageBox -icon warning -type ok \\\n"
|
8650 |
|
|
"\011 -message \"\\\"$selectFilePath\\\" must be an absolute pathname\"\n"
|
8651 |
|
|
"return\n"
|
8652 |
|
|
"}\n"
|
8653 |
|
|
"if {![file exists $selectPath]} {\n"
|
8654 |
|
|
"tk_messageBox -icon warning -type ok \\\n"
|
8655 |
|
|
"\011 -message \"Directory \\\"$selectPath\\\" does not exist.\"\n"
|
8656 |
|
|
"return\n"
|
8657 |
|
|
"}\n"
|
8658 |
|
|
"if {![file exists $selectFilePath]} {\n"
|
8659 |
|
|
"if {[string equal $data(type) open]} {\n"
|
8660 |
|
|
"tk_messageBox -icon warning -type ok \\\n"
|
8661 |
|
|
"\011\011-message \"File \\\"$selectFilePath\\\" does not exist.\"\n"
|
8662 |
|
|
"return\n"
|
8663 |
|
|
"}\n"
|
8664 |
|
|
"} else {\n"
|
8665 |
|
|
"if {[string equal $data(type) save]} {\n"
|
8666 |
|
|
"set message [format %s%s \\\n"
|
8667 |
|
|
"\011\011\"File \\\"$selectFilePath\\\" already exists.\\n\\n\" \\\n"
|
8668 |
|
|
"\011\011\"Replace existing file?\"]\n"
|
8669 |
|
|
"set answer [tk_messageBox -icon warning -type yesno \\\n"
|
8670 |
|
|
"\011\011-message $message]\n"
|
8671 |
|
|
"if {[string equal $answer \"no\"]} {\n"
|
8672 |
|
|
"return\n"
|
8673 |
|
|
"}\n"
|
8674 |
|
|
"}\n"
|
8675 |
|
|
"}\n"
|
8676 |
|
|
"set tkPriv(selectFilePath) $selectFilePath\n"
|
8677 |
|
|
"set tkPriv(selectFile) $selectFile\n"
|
8678 |
|
|
"set tkPriv(selectPath) $selectPath\n"
|
8679 |
|
|
"}\n"
|
8680 |
|
|
"proc tkMotifFDialog_OkCmd {w} {\n"
|
8681 |
|
|
"upvar ::tk::dialog::file::[winfo name $w] data\n"
|
8682 |
|
|
"tkMotifFDialog_ActivateSEnt $w\n"
|
8683 |
|
|
"}\n"
|
8684 |
|
|
"proc tkMotifFDialog_FilterCmd {w} {\n"
|
8685 |
|
|
"upvar ::tk::dialog::file::[winfo name $w] data\n"
|
8686 |
|
|
"tkMotifFDialog_ActivateFEnt $w\n"
|
8687 |
|
|
"}\n"
|
8688 |
|
|
"proc tkMotifFDialog_CancelCmd {w} {\n"
|
8689 |
|
|
"global tkPriv\n"
|
8690 |
|
|
"set tkPriv(selectFilePath) \"\"\n"
|
8691 |
|
|
"set tkPriv(selectFile) \"\"\n"
|
8692 |
|
|
"set tkPriv(selectPath) \"\"\n"
|
8693 |
|
|
"}\n"
|
8694 |
|
|
"proc tkListBoxKeyAccel_Set {w} {\n"
|
8695 |
|
|
"bind Listbox <Any-KeyPress> \"\"\n"
|
8696 |
|
|
"bind $w <Destroy> [list tkListBoxKeyAccel_Unset $w]\n"
|
8697 |
|
|
"bind $w <Any-KeyPress> [list tkListBoxKeyAccel_Key $w %A]\n"
|
8698 |
|
|
"}\n"
|
8699 |
|
|
"proc tkListBoxKeyAccel_Unset {w} {\n"
|
8700 |
|
|
"global tkPriv\n"
|
8701 |
|
|
"catch {after cancel $tkPriv(lbAccel,$w,afterId)}\n"
|
8702 |
|
|
"catch {unset tkPriv(lbAccel,$w)}\n"
|
8703 |
|
|
"catch {unset tkPriv(lbAccel,$w,afterId)}\n"
|
8704 |
|
|
"}\n"
|
8705 |
|
|
"proc tkListBoxKeyAccel_Key {w key} {\n"
|
8706 |
|
|
"global tkPriv\n"
|
8707 |
|
|
"append tkPriv(lbAccel,$w) $key\n"
|
8708 |
|
|
"tkListBoxKeyAccel_Goto $w $tkPriv(lbAccel,$w)\n"
|
8709 |
|
|
"catch {\n"
|
8710 |
|
|
"after cancel $tkPriv(lbAccel,$w,afterId)\n"
|
8711 |
|
|
"}\n"
|
8712 |
|
|
"set tkPriv(lbAccel,$w,afterId) [after 500 \\\n"
|
8713 |
|
|
"\011 [list tkListBoxKeyAccel_Reset $w]]\n"
|
8714 |
|
|
"}\n"
|
8715 |
|
|
"proc tkListBoxKeyAccel_Goto {w string} {\n"
|
8716 |
|
|
"global tkPriv\n"
|
8717 |
|
|
"set string [string tolower $string]\n"
|
8718 |
|
|
"set end [$w index end]\n"
|
8719 |
|
|
"set theIndex -1\n"
|
8720 |
|
|
"for {set i 0} {$i < $end} {incr i} {\n"
|
8721 |
|
|
"set item [string tolower [$w get $i]]\n"
|
8722 |
|
|
"if {[string compare $string $item] >= 0} {\n"
|
8723 |
|
|
"set theIndex $i\n"
|
8724 |
|
|
"}\n"
|
8725 |
|
|
"if {[string compare $string $item] <= 0} {\n"
|
8726 |
|
|
"set theIndex $i\n"
|
8727 |
|
|
"break\n"
|
8728 |
|
|
"}\n"
|
8729 |
|
|
"}\n"
|
8730 |
|
|
"if {$theIndex >= 0} {\n"
|
8731 |
|
|
"$w selection clear 0 end\n"
|
8732 |
|
|
"$w selection set $theIndex $theIndex\n"
|
8733 |
|
|
"$w activate $theIndex\n"
|
8734 |
|
|
"$w see $theIndex\n"
|
8735 |
|
|
"}\n"
|
8736 |
|
|
"}\n"
|
8737 |
|
|
"proc tkListBoxKeyAccel_Reset {w} {\n"
|
8738 |
|
|
"global tkPriv\n"
|
8739 |
|
|
"catch {unset tkPriv(lbAccel,$w)}\n"
|
8740 |
|
|
"}\n"
|
8741 |
|
|
;
|
8742 |
|
|
struct EtFile {
|
8743 |
|
|
char *zName;
|
8744 |
|
|
char *zData;
|
8745 |
|
|
int nData;
|
8746 |
|
|
int shrouded;
|
8747 |
|
|
struct EtFile *pNext;
|
8748 |
|
|
};
|
8749 |
|
|
static struct EtFile Et_FileSet[] = {
|
8750 |
|
|
{ "C:/PROGRAM FILES/TCL/lib/tcl8.3/auto.tcl", Et_zFile0, sizeof(Et_zFile0)-1, 0, 0 },
|
8751 |
|
|
{ "C:/PROGRAM FILES/TCL/lib/tcl8.3/history.tcl", Et_zFile1, sizeof(Et_zFile1)-1, 0, 0 },
|
8752 |
|
|
{ "C:/PROGRAM FILES/TCL/lib/tcl8.3/init.tcl", Et_zFile2, sizeof(Et_zFile2)-1, 0, 0 },
|
8753 |
|
|
{ "C:/PROGRAM FILES/TCL/lib/tcl8.3/package.tcl", Et_zFile3, sizeof(Et_zFile3)-1, 0, 0 },
|
8754 |
|
|
{ "C:/PROGRAM FILES/TCL/lib/tcl8.3/parray.tcl", Et_zFile4, sizeof(Et_zFile4)-1, 0, 0 },
|
8755 |
|
|
{ "C:/PROGRAM FILES/TCL/lib/tcl8.3/safe.tcl", Et_zFile5, sizeof(Et_zFile5)-1, 0, 0 },
|
8756 |
|
|
{ "C:/PROGRAM FILES/TCL/lib/tcl8.3/tclIndex", Et_zFile6, sizeof(Et_zFile6)-1, 0, 0 },
|
8757 |
|
|
{ "C:/PROGRAM FILES/TCL/lib/tcl8.3/word.tcl", Et_zFile7, sizeof(Et_zFile7)-1, 0, 0 },
|
8758 |
|
|
{ "C:/PROGRAM FILES/TCL/lib/tk8.3/bgerror.tcl", Et_zFile8, sizeof(Et_zFile8)-1, 0, 0 },
|
8759 |
|
|
{ "C:/PROGRAM FILES/TCL/lib/tk8.3/button.tcl", Et_zFile9, sizeof(Et_zFile9)-1, 0, 0 },
|
8760 |
|
|
{ "C:/PROGRAM FILES/TCL/lib/tk8.3/clrpick.tcl", Et_zFile10, sizeof(Et_zFile10)-1, 0, 0 },
|
8761 |
|
|
{ "C:/PROGRAM FILES/TCL/lib/tk8.3/comdlg.tcl", Et_zFile11, sizeof(Et_zFile11)-1, 0, 0 },
|
8762 |
|
|
{ "C:/PROGRAM FILES/TCL/lib/tk8.3/console.tcl", Et_zFile12, sizeof(Et_zFile12)-1, 0, 0 },
|
8763 |
|
|
{ "C:/PROGRAM FILES/TCL/lib/tk8.3/dialog.tcl", Et_zFile13, sizeof(Et_zFile13)-1, 0, 0 },
|
8764 |
|
|
{ "C:/PROGRAM FILES/TCL/lib/tk8.3/entry.tcl", Et_zFile14, sizeof(Et_zFile14)-1, 0, 0 },
|
8765 |
|
|
{ "C:/PROGRAM FILES/TCL/lib/tk8.3/focus.tcl", Et_zFile15, sizeof(Et_zFile15)-1, 0, 0 },
|
8766 |
|
|
{ "C:/PROGRAM FILES/TCL/lib/tk8.3/listbox.tcl", Et_zFile16, sizeof(Et_zFile16)-1, 0, 0 },
|
8767 |
|
|
{ "C:/PROGRAM FILES/TCL/lib/tk8.3/menu.tcl", Et_zFile17, sizeof(Et_zFile17)-1, 0, 0 },
|
8768 |
|
|
{ "C:/PROGRAM FILES/TCL/lib/tk8.3/msgbox.tcl", Et_zFile18, sizeof(Et_zFile18)-1, 0, 0 },
|
8769 |
|
|
{ "C:/PROGRAM FILES/TCL/lib/tk8.3/obsolete.tcl", Et_zFile19, sizeof(Et_zFile19)-1, 0, 0 },
|
8770 |
|
|
{ "C:/PROGRAM FILES/TCL/lib/tk8.3/optMenu.tcl", Et_zFile20, sizeof(Et_zFile20)-1, 0, 0 },
|
8771 |
|
|
{ "C:/PROGRAM FILES/TCL/lib/tk8.3/palette.tcl", Et_zFile21, sizeof(Et_zFile21)-1, 0, 0 },
|
8772 |
|
|
{ "C:/PROGRAM FILES/TCL/lib/tk8.3/safetk.tcl", Et_zFile22, sizeof(Et_zFile22)-1, 0, 0 },
|
8773 |
|
|
{ "C:/PROGRAM FILES/TCL/lib/tk8.3/scale.tcl", Et_zFile23, sizeof(Et_zFile23)-1, 0, 0 },
|
8774 |
|
|
{ "C:/PROGRAM FILES/TCL/lib/tk8.3/scrlbar.tcl", Et_zFile24, sizeof(Et_zFile24)-1, 0, 0 },
|
8775 |
|
|
{ "C:/PROGRAM FILES/TCL/lib/tk8.3/tclIndex", Et_zFile25, sizeof(Et_zFile25)-1, 0, 0 },
|
8776 |
|
|
{ "C:/PROGRAM FILES/TCL/lib/tk8.3/tearoff.tcl", Et_zFile26, sizeof(Et_zFile26)-1, 0, 0 },
|
8777 |
|
|
{ "C:/PROGRAM FILES/TCL/lib/tk8.3/text.tcl", Et_zFile27, sizeof(Et_zFile27)-1, 0, 0 },
|
8778 |
|
|
{ "C:/PROGRAM FILES/TCL/lib/tk8.3/tk.tcl", Et_zFile28, sizeof(Et_zFile28)-1, 0, 0 },
|
8779 |
|
|
{ "C:/PROGRAM FILES/TCL/lib/tk8.3/tkfbox.tcl", Et_zFile29, sizeof(Et_zFile29)-1, 0, 0 },
|
8780 |
|
|
{ "C:/PROGRAM FILES/TCL/lib/tk8.3/xmfbox.tcl", Et_zFile30, sizeof(Et_zFile30)-1, 0, 0 },
|
8781 |
|
|
{0, 0}};
|
8782 |
|
|
static struct EtFile *Et_FileHashTable[71];
|
8783 |
|
|
/* The following copyright notice applies to code generated by
|
8784 |
|
|
** "mktclapp". The "mktclapp" program itself is covered by the
|
8785 |
|
|
** GNU Public License.
|
8786 |
|
|
**
|
8787 |
|
|
** Copyright (c) 1998 D. Richard Hipp
|
8788 |
|
|
**
|
8789 |
|
|
** The author hereby grants permission to use, copy, modify, distribute,
|
8790 |
|
|
** and license this software and its documentation for any purpose, provided
|
8791 |
|
|
** that existing copyright notices are retained in all copies and that this
|
8792 |
|
|
** notice is included verbatim in any distributions. No written agreement,
|
8793 |
|
|
** license, or royalty fee is required for any of the authorized uses.
|
8794 |
|
|
** Modifications to this software may be copyrighted by their authors
|
8795 |
|
|
** and need not follow the licensing terms described here, provided that
|
8796 |
|
|
** the new terms are clearly indicated on the first page of each file where
|
8797 |
|
|
** they apply.
|
8798 |
|
|
**
|
8799 |
|
|
** In no event shall the author or the distributors be liable to any party
|
8800 |
|
|
** for direct, indirect, special, incidental, or consequential damages
|
8801 |
|
|
** arising out of the use of this software, its documentation, or any
|
8802 |
|
|
** derivatives thereof, even if the author has been advised of the
|
8803 |
|
|
** possibility of such damage. The author and distributors specifically
|
8804 |
|
|
** disclaim any warranties, including but not limited to the implied
|
8805 |
|
|
** warranties of merchantability, fitness for a particular purpose, and
|
8806 |
|
|
** non-infringment. This software is provided at no fee on an
|
8807 |
|
|
** "as is" basis. The author and/or distritutors have no obligation
|
8808 |
|
|
** to provide maintenance, support, updates, enhancements and/or
|
8809 |
|
|
** modifications.
|
8810 |
|
|
**
|
8811 |
|
|
** GOVERNMENT USE: If you are acquiring this software on behalf of the
|
8812 |
|
|
** U.S. government, the Government shall have only "Restricted Rights"
|
8813 |
|
|
** in the software and related documentation as defined in the Federal
|
8814 |
|
|
** Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you
|
8815 |
|
|
** are acquiring the software on behalf of the Department of Defense, the
|
8816 |
|
|
** software shall be classified as "Commercial Computer Software" and the
|
8817 |
|
|
** Government shall have only "Restricted Rights" as defined in Clause
|
8818 |
|
|
** 252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the
|
8819 |
|
|
** author grants the U.S. Government and others acting in its behalf
|
8820 |
|
|
** permission to use and distribute the software in accordance with the
|
8821 |
|
|
** terms specified in this license.
|
8822 |
|
|
*/
|
8823 |
|
|
#include <ctype.h>
|
8824 |
|
|
#include <string.h>
|
8825 |
|
|
#include <stdarg.h>
|
8826 |
|
|
#include <stdio.h>
|
8827 |
|
|
#include <stdlib.h>
|
8828 |
|
|
#include <sys/types.h>
|
8829 |
|
|
#include <sys/stat.h>
|
8830 |
|
|
#include <fcntl.h>
|
8831 |
|
|
|
8832 |
|
|
/* Include either the Tcl or the Tk header file. Use the "Internal"
|
8833 |
|
|
** version of the header file if and only if we are generating an
|
8834 |
|
|
** extension that is linking against the Stub library.
|
8835 |
|
|
** Many installations do not have the internal header files
|
8836 |
|
|
** available, so using the internal headers only when absolutely
|
8837 |
|
|
** necessary will help to reduce compilation problems.
|
8838 |
|
|
*/
|
8839 |
|
|
#if ET_EXTENSION && defined(TCL_USE_STUBS)
|
8840 |
|
|
# if ET_ENABLE_TK
|
8841 |
|
|
# include <tkInt.h>
|
8842 |
|
|
# else
|
8843 |
|
|
# include <tclInt.h>
|
8844 |
|
|
# endif
|
8845 |
|
|
#else
|
8846 |
|
|
# if ET_ENABLE_TK
|
8847 |
|
|
# include <tk.h>
|
8848 |
|
|
# else
|
8849 |
|
|
# include <tcl.h>
|
8850 |
|
|
# endif
|
8851 |
|
|
#endif
|
8852 |
|
|
|
8853 |
|
|
/*
|
8854 |
|
|
** ET_WIN32 is true if we are running Tk under windows. The
|
8855 |
|
|
** <tcl.h> module will define __WIN32__ for us if we are compiling
|
8856 |
|
|
** for windows.
|
8857 |
|
|
*/
|
8858 |
|
|
#if defined(__WIN32__) && ET_ENABLE_TK
|
8859 |
|
|
# define ET_WIN32 1
|
8860 |
|
|
# include <windows.h>
|
8861 |
|
|
#else
|
8862 |
|
|
# define ET_WIN32 0
|
8863 |
|
|
#endif
|
8864 |
|
|
|
8865 |
|
|
/*
|
8866 |
|
|
** Always disable ET_AUTO_FORK under windows. Windows doesn't
|
8867 |
|
|
** fork well.
|
8868 |
|
|
*/
|
8869 |
|
|
#if defined(__WIN32__)
|
8870 |
|
|
# undef ET_AUTO_FORK
|
8871 |
|
|
# define ET_AUTO_FORK 0
|
8872 |
|
|
#endif
|
8873 |
|
|
|
8874 |
|
|
/*
|
8875 |
|
|
** Omit <unistd.h> under windows. But we need it for Unix.
|
8876 |
|
|
*/
|
8877 |
|
|
#if !defined(__WIN32__)
|
8878 |
|
|
# include <unistd.h>
|
8879 |
|
|
#endif
|
8880 |
|
|
|
8881 |
|
|
/*
|
8882 |
|
|
** The Tcl*InsertProc functions allow the system calls "stat",
|
8883 |
|
|
** "access" and "open" to be overloaded. This in turns allows us
|
8884 |
|
|
** to substituted compiled-in strings for files in the filesystem.
|
8885 |
|
|
** But the Tcl*InsertProc functions are only available in Tcl8.0.3
|
8886 |
|
|
** and later.
|
8887 |
|
|
**
|
8888 |
|
|
** Define the ET_HAVE_INSERTPROC macro if and only if we are dealing
|
8889 |
|
|
** with Tcl8.0.3 or later.
|
8890 |
|
|
*/
|
8891 |
|
|
#if TCL_MAJOR_VERSION==8 && (TCL_MINOR_VERSION>0 || TCL_RELEASE_SERIAL>=3)
|
8892 |
|
|
# define ET_HAVE_INSERTPROC
|
8893 |
|
|
#endif
|
8894 |
|
|
|
8895 |
|
|
/*
|
8896 |
|
|
** If we are using the Tcl*InsertProc() functions, we should provide
|
8897 |
|
|
** prototypes for them. But the prototypes are in the tclInt.h include
|
8898 |
|
|
** file, which we don't want to require the user to have on hand. So
|
8899 |
|
|
** we provide our own prototypes here.
|
8900 |
|
|
**
|
8901 |
|
|
** Note that if TCL_USE_STUBS is defined, then the tclInt.h is required
|
8902 |
|
|
** anyway, so these prototypes are not included if TCL_USE_STUBS is
|
8903 |
|
|
** defined.
|
8904 |
|
|
*/
|
8905 |
|
|
#if defined(ET_HAVE_INSERTPROC) && !defined(TCL_USE_STUBS)
|
8906 |
|
|
#ifdef __cplusplus
|
8907 |
|
|
extern "C" int TclStatInsertProc(int (*)(char*, struct stat *));
|
8908 |
|
|
extern "C" int TclAccessInsertProc(int (*)(char*, int));
|
8909 |
|
|
extern "C" int TclOpenFileChannelInsertProc(Tcl_Channel (*)(Tcl_Interp*,char*,
|
8910 |
|
|
char*,int));
|
8911 |
|
|
#else
|
8912 |
|
|
extern int TclStatInsertProc(int (*)(char*, struct stat *));
|
8913 |
|
|
extern int TclAccessInsertProc(int (*)(char*, int));
|
8914 |
|
|
extern int TclOpenFileChannelInsertProc(Tcl_Channel (*)(Tcl_Interp*,char*,
|
8915 |
|
|
char*,int));
|
8916 |
|
|
#endif
|
8917 |
|
|
#endif
|
8918 |
|
|
|
8919 |
|
|
|
8920 |
|
|
/*
|
8921 |
|
|
** Don't allow Win32 applications to read from stdin. Nor
|
8922 |
|
|
** programs that automatically go into the background. Force
|
8923 |
|
|
** the use of a console in these cases.
|
8924 |
|
|
*/
|
8925 |
|
|
#if (ET_WIN32 || ET_AUTO_FORK) && ET_READ_STDIN
|
8926 |
|
|
# undef ET_READ_STDIN
|
8927 |
|
|
# undef ET_CONSOLE
|
8928 |
|
|
# define ET_READ_STDIN 0
|
8929 |
|
|
# define ET_CONSOLE 1
|
8930 |
|
|
#endif
|
8931 |
|
|
|
8932 |
|
|
/*
|
8933 |
|
|
** The console won't work without Tk.
|
8934 |
|
|
*/
|
8935 |
|
|
#if ET_ENABLE_TK==0 && ET_CONSOLE
|
8936 |
|
|
# undef ET_CONSOLE
|
8937 |
|
|
# define ET_CONSOLE 0
|
8938 |
|
|
# undef ET_READ_STDIN
|
8939 |
|
|
# define ET_READ_STDIN 1
|
8940 |
|
|
#endif
|
8941 |
|
|
|
8942 |
|
|
/*
|
8943 |
|
|
** We MUST start using Tcl_GetStringResult() in Tcl8.3
|
8944 |
|
|
** But these functions didn't exists in Tcl 7.6. So make
|
8945 |
|
|
** them macros.
|
8946 |
|
|
*/
|
8947 |
|
|
#if TCL_MAJOR_VERSION<8
|
8948 |
|
|
# define Tcl_GetStringResult(I) ((I)->result)
|
8949 |
|
|
#endif
|
8950 |
|
|
|
8951 |
|
|
/*
|
8952 |
|
|
** Set ET_HAVE_OBJ to true if we are able to link against the
|
8953 |
|
|
** new Tcl_Obj interface. This is only the case for Tcl version
|
8954 |
|
|
** 8.0 and later.
|
8955 |
|
|
*/
|
8956 |
|
|
#if ET_ENABLE_OBJ || TCL_MAJOR_VERSION>=8
|
8957 |
|
|
# define ET_HAVE_OBJ 1
|
8958 |
|
|
#else
|
8959 |
|
|
# define ET_HAVE_OBJ 0
|
8960 |
|
|
#endif
|
8961 |
|
|
|
8962 |
|
|
/*
|
8963 |
|
|
** The Tcl_GetByteArrayFromObj() only appears in Tcl version 8.1
|
8964 |
|
|
** and later. Substitute Tcl_GetStringFromObj() in Tcl version 8.0.X
|
8965 |
|
|
*/
|
8966 |
|
|
#if ET_HAVE_OBJ && TCL_MINOR_VERSION==0
|
8967 |
|
|
# define Tcl_GetByteArrayFromObj Tcl_GetStringFromObj
|
8968 |
|
|
#endif
|
8969 |
|
|
|
8970 |
|
|
/*
|
8971 |
|
|
** Tcl code to implement the console.
|
8972 |
|
|
**
|
8973 |
|
|
** This code is written and tested separately, then run through
|
8974 |
|
|
** "mktclapp -stringify" and then pasted in here.
|
8975 |
|
|
*/
|
8976 |
|
|
#if ET_ENABLE_TK && !ET_EXTENSION
|
8977 |
|
|
static char zEtConsole[] =
|
8978 |
|
|
"proc console:create {w prompt title} {\n"
|
8979 |
|
|
"upvar #0 $w.t v\n"
|
8980 |
|
|
"if {[winfo exists $w]} {destroy $w}\n"
|
8981 |
|
|
"if {[info exists v]} {unset v}\n"
|
8982 |
|
|
"toplevel $w\n"
|
8983 |
|
|
"wm title $w $title\n"
|
8984 |
|
|
"wm iconname $w $title\n"
|
8985 |
|
|
"frame $w.mb -bd 2 -relief raised\n"
|
8986 |
|
|
"pack $w.mb -side top -fill x\n"
|
8987 |
|
|
"menubutton $w.mb.file -text File -menu $w.mb.file.m\n"
|
8988 |
|
|
"menubutton $w.mb.edit -text Edit -menu $w.mb.edit.m\n"
|
8989 |
|
|
"pack $w.mb.file $w.mb.edit -side left -padx 8 -pady 1\n"
|
8990 |
|
|
"set m [menu $w.mb.file.m]\n"
|
8991 |
|
|
"$m add command -label {Source...} -command \"console:SourceFile $w.t\"\n"
|
8992 |
|
|
"$m add command -label {Save As...} -command \"console:SaveFile $w.t\"\n"
|
8993 |
|
|
"$m add separator\n"
|
8994 |
|
|
"$m add command -label {Close} -command \"destroy $w\"\n"
|
8995 |
|
|
"$m add command -label {Exit} -command exit\n"
|
8996 |
|
|
"set m [menu $w.mb.edit.m]\n"
|
8997 |
|
|
"$m add command -label Cut -command \"console:Cut $w.t\"\n"
|
8998 |
|
|
"$m add command -label Copy -command \"console:Copy $w.t\"\n"
|
8999 |
|
|
"$m add command -label Paste -command \"console:Paste $w.t\"\n"
|
9000 |
|
|
"$m add command -label {Clear Screen} -command \"console:Clear $w.t\"\n"
|
9001 |
|
|
"catch {$m config -postcommand \"console:EnableEditMenu $w\"}\n"
|
9002 |
|
|
"scrollbar $w.sb -orient vertical -command \"$w.t yview\"\n"
|
9003 |
|
|
"pack $w.sb -side right -fill y\n"
|
9004 |
|
|
"text $w.t -font fixed -yscrollcommand \"$w.sb set\"\n"
|
9005 |
|
|
"pack $w.t -side right -fill both -expand 1\n"
|
9006 |
|
|
"bindtags $w.t Console\n"
|
9007 |
|
|
"set v(text) $w.t\n"
|
9008 |
|
|
"set v(history) 0\n"
|
9009 |
|
|
"set v(historycnt) 0\n"
|
9010 |
|
|
"set v(current) -1\n"
|
9011 |
|
|
"set v(prompt) $prompt\n"
|
9012 |
|
|
"set v(prior) {}\n"
|
9013 |
|
|
"set v(plength) [string length $v(prompt)]\n"
|
9014 |
|
|
"set v(x) 0\n"
|
9015 |
|
|
"set v(y) 0\n"
|
9016 |
|
|
"$w.t mark set insert end\n"
|
9017 |
|
|
"$w.t tag config ok -foreground blue\n"
|
9018 |
|
|
"$w.t tag config err -foreground red\n"
|
9019 |
|
|
"$w.t insert end $v(prompt)\n"
|
9020 |
|
|
"$w.t mark set out 1.0\n"
|
9021 |
|
|
"catch {rename puts console:oldputs$w}\n"
|
9022 |
|
|
"proc puts args [format {\n"
|
9023 |
|
|
"if {![winfo exists %s]} {\n"
|
9024 |
|
|
"rename puts {}\n"
|
9025 |
|
|
"rename console:oldputs%s puts\n"
|
9026 |
|
|
"return [uplevel #0 puts $args]\n"
|
9027 |
|
|
"}\n"
|
9028 |
|
|
"switch -glob -- \"[llength $args] $args\" {\n"
|
9029 |
|
|
"{1 *} {\n"
|
9030 |
|
|
"set msg [lindex $args 0]\\n\n"
|
9031 |
|
|
"set tag ok\n"
|
9032 |
|
|
"}\n"
|
9033 |
|
|
"{2 stdout *} {\n"
|
9034 |
|
|
"set msg [lindex $args 1]\\n\n"
|
9035 |
|
|
"set tag ok\n"
|
9036 |
|
|
"}\n"
|
9037 |
|
|
"{2 stderr *} {\n"
|
9038 |
|
|
"set msg [lindex $args 1]\\n\n"
|
9039 |
|
|
"set tag err\n"
|
9040 |
|
|
"}\n"
|
9041 |
|
|
"{2 -nonewline *} {\n"
|
9042 |
|
|
"set msg [lindex $args 1]\n"
|
9043 |
|
|
"set tag ok\n"
|
9044 |
|
|
"}\n"
|
9045 |
|
|
"{3 -nonewline stdout *} {\n"
|
9046 |
|
|
"set msg [lindex $args 2]\n"
|
9047 |
|
|
"set tag ok\n"
|
9048 |
|
|
"}\n"
|
9049 |
|
|
"{3 -nonewline stderr *} {\n"
|
9050 |
|
|
"set msg [lindex $args 2]\n"
|
9051 |
|
|
"set tag err\n"
|
9052 |
|
|
"}\n"
|
9053 |
|
|
"default {\n"
|
9054 |
|
|
"uplevel #0 console:oldputs%s $args\n"
|
9055 |
|
|
"return\n"
|
9056 |
|
|
"}\n"
|
9057 |
|
|
"}\n"
|
9058 |
|
|
"console:Puts %s $msg $tag\n"
|
9059 |
|
|
"} $w $w $w $w.t]\n"
|
9060 |
|
|
"after idle \"focus $w.t\"\n"
|
9061 |
|
|
"}\n"
|
9062 |
|
|
"bind Console <1> {console:Button1 %W %x %y}\n"
|
9063 |
|
|
"bind Console <B1-Motion> {console:B1Motion %W %x %y}\n"
|
9064 |
|
|
"bind Console <B1-Leave> {console:B1Leave %W %x %y}\n"
|
9065 |
|
|
"bind Console <B1-Enter> {console:cancelMotor %W}\n"
|
9066 |
|
|
"bind Console <ButtonRelease-1> {console:cancelMotor %W}\n"
|
9067 |
|
|
"bind Console <KeyPress> {console:Insert %W %A}\n"
|
9068 |
|
|
"bind Console <Left> {console:Left %W}\n"
|
9069 |
|
|
"bind Console <Control-b> {console:Left %W}\n"
|
9070 |
|
|
"bind Console <Right> {console:Right %W}\n"
|
9071 |
|
|
"bind Console <Control-f> {console:Right %W}\n"
|
9072 |
|
|
"bind Console <BackSpace> {console:Backspace %W}\n"
|
9073 |
|
|
"bind Console <Control-h> {console:Backspace %W}\n"
|
9074 |
|
|
"bind Console <Delete> {console:Delete %W}\n"
|
9075 |
|
|
"bind Console <Control-d> {console:Delete %W}\n"
|
9076 |
|
|
"bind Console <Home> {console:Home %W}\n"
|
9077 |
|
|
"bind Console <Control-a> {console:Home %W}\n"
|
9078 |
|
|
"bind Console <End> {console:End %W}\n"
|
9079 |
|
|
"bind Console <Control-e> {console:End %W}\n"
|
9080 |
|
|
"bind Console <Return> {console:Enter %W}\n"
|
9081 |
|
|
"bind Console <KP_Enter> {console:Enter %W}\n"
|
9082 |
|
|
"bind Console <Up> {console:Prior %W}\n"
|
9083 |
|
|
"bind Console <Control-p> {console:Prior %W}\n"
|
9084 |
|
|
"bind Console <Down> {console:Next %W}\n"
|
9085 |
|
|
"bind Console <Control-n> {console:Next %W}\n"
|
9086 |
|
|
"bind Console <Control-k> {console:EraseEOL %W}\n"
|
9087 |
|
|
"bind Console <<Cut>> {console:Cut %W}\n"
|
9088 |
|
|
"bind Console <<Copy>> {console:Copy %W}\n"
|
9089 |
|
|
"bind Console <<Paste>> {console:Paste %W}\n"
|
9090 |
|
|
"bind Console <<Clear>> {console:Clear %W}\n"
|
9091 |
|
|
"proc console:Puts {w t tag} {\n"
|
9092 |
|
|
"set nc [string length $t]\n"
|
9093 |
|
|
"set endc [string index $t [expr $nc-1]]\n"
|
9094 |
|
|
"if {$endc==\"\\n\"} {\n"
|
9095 |
|
|
"if {[$w index out]<[$w index {insert linestart}]} {\n"
|
9096 |
|
|
"$w insert out [string range $t 0 [expr $nc-2]] $tag\n"
|
9097 |
|
|
"$w mark set out {out linestart +1 lines}\n"
|
9098 |
|
|
"} else {\n"
|
9099 |
|
|
"$w insert out $t $tag\n"
|
9100 |
|
|
"}\n"
|
9101 |
|
|
"} else {\n"
|
9102 |
|
|
"if {[$w index out]<[$w index {insert linestart}]} {\n"
|
9103 |
|
|
"$w insert out $t $tag\n"
|
9104 |
|
|
"} else {\n"
|
9105 |
|
|
"$w insert out $t\\n $tag\n"
|
9106 |
|
|
"$w mark set out {out -1 char}\n"
|
9107 |
|
|
"}\n"
|
9108 |
|
|
"}\n"
|
9109 |
|
|
"$w yview insert\n"
|
9110 |
|
|
"}\n"
|
9111 |
|
|
"proc console:Insert {w a} {\n"
|
9112 |
|
|
"$w insert insert $a\n"
|
9113 |
|
|
"$w yview insert\n"
|
9114 |
|
|
"}\n"
|
9115 |
|
|
"proc console:Left {w} {\n"
|
9116 |
|
|
"upvar #0 $w v\n"
|
9117 |
|
|
"scan [$w index insert] %d.%d row col\n"
|
9118 |
|
|
"if {$col>$v(plength)} {\n"
|
9119 |
|
|
"$w mark set insert \"insert -1c\"\n"
|
9120 |
|
|
"}\n"
|
9121 |
|
|
"}\n"
|
9122 |
|
|
"proc console:Backspace {w} {\n"
|
9123 |
|
|
"upvar #0 $w v\n"
|
9124 |
|
|
"scan [$w index insert] %d.%d row col\n"
|
9125 |
|
|
"if {$col>$v(plength)} {\n"
|
9126 |
|
|
"$w delete {insert -1c}\n"
|
9127 |
|
|
"}\n"
|
9128 |
|
|
"}\n"
|
9129 |
|
|
"proc console:EraseEOL {w} {\n"
|
9130 |
|
|
"upvar #0 $w v\n"
|
9131 |
|
|
"scan [$w index insert] %d.%d row col\n"
|
9132 |
|
|
"if {$col>=$v(plength)} {\n"
|
9133 |
|
|
"$w delete insert {insert lineend}\n"
|
9134 |
|
|
"}\n"
|
9135 |
|
|
"}\n"
|
9136 |
|
|
"proc console:Right {w} {\n"
|
9137 |
|
|
"$w mark set insert \"insert +1c\"\n"
|
9138 |
|
|
"}\n"
|
9139 |
|
|
"proc console:Delete w {\n"
|
9140 |
|
|
"$w delete insert\n"
|
9141 |
|
|
"}\n"
|
9142 |
|
|
"proc console:Home w {\n"
|
9143 |
|
|
"upvar #0 $w v\n"
|
9144 |
|
|
"scan [$w index insert] %d.%d row col\n"
|
9145 |
|
|
"$w mark set insert $row.$v(plength)\n"
|
9146 |
|
|
"}\n"
|
9147 |
|
|
"proc console:End w {\n"
|
9148 |
|
|
"$w mark set insert {insert lineend}\n"
|
9149 |
|
|
"}\n"
|
9150 |
|
|
"proc console:Enter w {\n"
|
9151 |
|
|
"upvar #0 $w v\n"
|
9152 |
|
|
"scan [$w index insert] %d.%d row col\n"
|
9153 |
|
|
"set start $row.$v(plength)\n"
|
9154 |
|
|
"set line [$w get $start \"$start lineend\"]\n"
|
9155 |
|
|
"if {$v(historycnt)>0} {\n"
|
9156 |
|
|
"set last [lindex $v(history) [expr $v(historycnt)-1]]\n"
|
9157 |
|
|
"if {[string compare $last $line]} {\n"
|
9158 |
|
|
"lappend v(history) $line\n"
|
9159 |
|
|
"incr v(historycnt)\n"
|
9160 |
|
|
"}\n"
|
9161 |
|
|
"} else {\n"
|
9162 |
|
|
"set v(history) [list $line]\n"
|
9163 |
|
|
"set v(historycnt) 1\n"
|
9164 |
|
|
"}\n"
|
9165 |
|
|
"set v(current) $v(historycnt)\n"
|
9166 |
|
|
"$w insert end \\n\n"
|
9167 |
|
|
"$w mark set out end\n"
|
9168 |
|
|
"if {$v(prior)==\"\"} {\n"
|
9169 |
|
|
"set cmd $line\n"
|
9170 |
|
|
"} else {\n"
|
9171 |
|
|
"set cmd $v(prior)\\n$line\n"
|
9172 |
|
|
"}\n"
|
9173 |
|
|
"if {[info complete $cmd]} {\n"
|
9174 |
|
|
"set rc [catch {uplevel #0 $cmd} res]\n"
|
9175 |
|
|
"if {![winfo exists $w]} return\n"
|
9176 |
|
|
"if {$rc} {\n"
|
9177 |
|
|
"$w insert end $res\\n err\n"
|
9178 |
|
|
"} elseif {[string length $res]>0} {\n"
|
9179 |
|
|
"$w insert end $res\\n ok\n"
|
9180 |
|
|
"}\n"
|
9181 |
|
|
"set v(prior) {}\n"
|
9182 |
|
|
"$w insert end $v(prompt)\n"
|
9183 |
|
|
"} else {\n"
|
9184 |
|
|
"set v(prior) $cmd\n"
|
9185 |
|
|
"regsub -all {[^ ]} $v(prompt) . x\n"
|
9186 |
|
|
"$w insert end $x\n"
|
9187 |
|
|
"}\n"
|
9188 |
|
|
"$w mark set insert end\n"
|
9189 |
|
|
"$w mark set out {insert linestart}\n"
|
9190 |
|
|
"$w yview insert\n"
|
9191 |
|
|
"}\n"
|
9192 |
|
|
"proc console:Prior w {\n"
|
9193 |
|
|
"upvar #0 $w v\n"
|
9194 |
|
|
"if {$v(current)<=0} return\n"
|
9195 |
|
|
"incr v(current) -1\n"
|
9196 |
|
|
"set line [lindex $v(history) $v(current)]\n"
|
9197 |
|
|
"console:SetLine $w $line\n"
|
9198 |
|
|
"}\n"
|
9199 |
|
|
"proc console:Next w {\n"
|
9200 |
|
|
"upvar #0 $w v\n"
|
9201 |
|
|
"if {$v(current)>=$v(historycnt)} return\n"
|
9202 |
|
|
"incr v(current) 1\n"
|
9203 |
|
|
"set line [lindex $v(history) $v(current)]\n"
|
9204 |
|
|
"console:SetLine $w $line\n"
|
9205 |
|
|
"}\n"
|
9206 |
|
|
"proc console:SetLine {w line} {\n"
|
9207 |
|
|
"upvar #0 $w v\n"
|
9208 |
|
|
"scan [$w index insert] %d.%d row col\n"
|
9209 |
|
|
"set start $row.$v(plength)\n"
|
9210 |
|
|
"$w delete $start end\n"
|
9211 |
|
|
"$w insert end $line\n"
|
9212 |
|
|
"$w mark set insert end\n"
|
9213 |
|
|
"$w yview insert\n"
|
9214 |
|
|
"}\n"
|
9215 |
|
|
"proc console:Button1 {w x y} {\n"
|
9216 |
|
|
"global tkPriv\n"
|
9217 |
|
|
"upvar #0 $w v\n"
|
9218 |
|
|
"set v(mouseMoved) 0\n"
|
9219 |
|
|
"set v(pressX) $x\n"
|
9220 |
|
|
"set p [console:nearestBoundry $w $x $y]\n"
|
9221 |
|
|
"scan [$w index insert] %d.%d ix iy\n"
|
9222 |
|
|
"scan $p %d.%d px py\n"
|
9223 |
|
|
"if {$px==$ix} {\n"
|
9224 |
|
|
"$w mark set insert $p\n"
|
9225 |
|
|
"}\n"
|
9226 |
|
|
"$w mark set anchor $p\n"
|
9227 |
|
|
"focus $w\n"
|
9228 |
|
|
"}\n"
|
9229 |
|
|
"proc console:nearestBoundry {w x y} {\n"
|
9230 |
|
|
"set p [$w index @$x,$y]\n"
|
9231 |
|
|
"set bb [$w bbox $p]\n"
|
9232 |
|
|
"if {![string compare $bb \"\"]} {return $p}\n"
|
9233 |
|
|
"if {($x-[lindex $bb 0])<([lindex $bb 2]/2)} {return $p}\n"
|
9234 |
|
|
"$w index \"$p + 1 char\"\n"
|
9235 |
|
|
"}\n"
|
9236 |
|
|
"proc console:SelectTo {w x y} {\n"
|
9237 |
|
|
"upvar #0 $w v\n"
|
9238 |
|
|
"set cur [console:nearestBoundry $w $x $y]\n"
|
9239 |
|
|
"if {[catch {$w index anchor}]} {\n"
|
9240 |
|
|
"$w mark set anchor $cur\n"
|
9241 |
|
|
"}\n"
|
9242 |
|
|
"set anchor [$w index anchor]\n"
|
9243 |
|
|
"if {[$w compare $cur != $anchor] || (abs($v(pressX) - $x) >= 3)} {\n"
|
9244 |
|
|
"if {$v(mouseMoved)==0} {\n"
|
9245 |
|
|
"$w tag remove sel 0.0 end\n"
|
9246 |
|
|
"}\n"
|
9247 |
|
|
"set v(mouseMoved) 1\n"
|
9248 |
|
|
"}\n"
|
9249 |
|
|
"if {[$w compare $cur < anchor]} {\n"
|
9250 |
|
|
"set first $cur\n"
|
9251 |
|
|
"set last anchor\n"
|
9252 |
|
|
"} else {\n"
|
9253 |
|
|
"set first anchor\n"
|
9254 |
|
|
"set last $cur\n"
|
9255 |
|
|
"}\n"
|
9256 |
|
|
"if {$v(mouseMoved)} {\n"
|
9257 |
|
|
"$w tag remove sel 0.0 $first\n"
|
9258 |
|
|
"$w tag add sel $first $last\n"
|
9259 |
|
|
"$w tag remove sel $last end\n"
|
9260 |
|
|
"update idletasks\n"
|
9261 |
|
|
"}\n"
|
9262 |
|
|
"}\n"
|
9263 |
|
|
"proc console:B1Motion {w x y} {\n"
|
9264 |
|
|
"upvar #0 $w v\n"
|
9265 |
|
|
"set v(y) $y\n"
|
9266 |
|
|
"set v(x) $x\n"
|
9267 |
|
|
"console:SelectTo $w $x $y\n"
|
9268 |
|
|
"}\n"
|
9269 |
|
|
"proc console:B1Leave {w x y} {\n"
|
9270 |
|
|
"upvar #0 $w v\n"
|
9271 |
|
|
"set v(y) $y\n"
|
9272 |
|
|
"set v(x) $x\n"
|
9273 |
|
|
"console:motor $w\n"
|
9274 |
|
|
"}\n"
|
9275 |
|
|
"proc console:motor w {\n"
|
9276 |
|
|
"upvar #0 $w v\n"
|
9277 |
|
|
"if {![winfo exists $w]} return\n"
|
9278 |
|
|
"if {$v(y)>=[winfo height $w]} {\n"
|
9279 |
|
|
"$w yview scroll 1 units\n"
|
9280 |
|
|
"} elseif {$v(y)<0} {\n"
|
9281 |
|
|
"$w yview scroll -1 units\n"
|
9282 |
|
|
"} else {\n"
|
9283 |
|
|
"return\n"
|
9284 |
|
|
"}\n"
|
9285 |
|
|
"console:SelectTo $w $v(x) $v(y)\n"
|
9286 |
|
|
"set v(timer) [after 50 console:motor $w]\n"
|
9287 |
|
|
"}\n"
|
9288 |
|
|
"proc console:cancelMotor w {\n"
|
9289 |
|
|
"upvar #0 $w v\n"
|
9290 |
|
|
"catch {after cancel $v(timer)}\n"
|
9291 |
|
|
"catch {unset v(timer)}\n"
|
9292 |
|
|
"}\n"
|
9293 |
|
|
"proc console:Copy w {\n"
|
9294 |
|
|
"if {![catch {set text [$w get sel.first sel.last]}]} {\n"
|
9295 |
|
|
"clipboard clear -displayof $w\n"
|
9296 |
|
|
"clipboard append -displayof $w $text\n"
|
9297 |
|
|
"}\n"
|
9298 |
|
|
"}\n"
|
9299 |
|
|
"proc console:canCut w {\n"
|
9300 |
|
|
"set r [catch {\n"
|
9301 |
|
|
"scan [$w index sel.first] %d.%d s1x s1y\n"
|
9302 |
|
|
"scan [$w index sel.last] %d.%d s2x s2y\n"
|
9303 |
|
|
"scan [$w index insert] %d.%d ix iy\n"
|
9304 |
|
|
"}]\n"
|
9305 |
|
|
"if {$r==1} {return 0}\n"
|
9306 |
|
|
"if {$s1x==$ix && $s2x==$ix} {return 1}\n"
|
9307 |
|
|
"return 2\n"
|
9308 |
|
|
"}\n"
|
9309 |
|
|
"proc console:Cut w {\n"
|
9310 |
|
|
"if {[console:canCut $w]==1} {\n"
|
9311 |
|
|
"console:Copy $w\n"
|
9312 |
|
|
"$w delete sel.first sel.last\n"
|
9313 |
|
|
"}\n"
|
9314 |
|
|
"}\n"
|
9315 |
|
|
"proc console:Paste w {\n"
|
9316 |
|
|
"if {[console:canCut $w]==1} {\n"
|
9317 |
|
|
"$w delete sel.first sel.last\n"
|
9318 |
|
|
"}\n"
|
9319 |
|
|
"if {[catch {selection get -displayof $w -selection CLIPBOARD} topaste]} {\n"
|
9320 |
|
|
"return\n"
|
9321 |
|
|
"}\n"
|
9322 |
|
|
"set prior 0\n"
|
9323 |
|
|
"foreach line [split $topaste \\n] {\n"
|
9324 |
|
|
"if {$prior} {\n"
|
9325 |
|
|
"console:Enter $w\n"
|
9326 |
|
|
"update\n"
|
9327 |
|
|
"}\n"
|
9328 |
|
|
"set prior 1\n"
|
9329 |
|
|
"$w insert insert $line\n"
|
9330 |
|
|
"}\n"
|
9331 |
|
|
"}\n"
|
9332 |
|
|
"proc console:EnableEditMenu w {\n"
|
9333 |
|
|
"set m $w.mb.edit.m\n"
|
9334 |
|
|
"switch [console:canCut $w.t] {\n"
|
9335 |
|
|
"0 {\n"
|
9336 |
|
|
"$m entryconf Copy -state disabled\n"
|
9337 |
|
|
"$m entryconf Cut -state disabled\n"
|
9338 |
|
|
"}\n"
|
9339 |
|
|
"1 {\n"
|
9340 |
|
|
"$m entryconf Copy -state normal\n"
|
9341 |
|
|
"$m entryconf Cut -state normal\n"
|
9342 |
|
|
"}\n"
|
9343 |
|
|
"2 {\n"
|
9344 |
|
|
"$m entryconf Copy -state normal\n"
|
9345 |
|
|
"$m entryconf Cut -state disabled\n"
|
9346 |
|
|
"}\n"
|
9347 |
|
|
"}\n"
|
9348 |
|
|
"}\n"
|
9349 |
|
|
"proc console:SourceFile w {\n"
|
9350 |
|
|
"set types {\n"
|
9351 |
|
|
"{{TCL Scripts} {.tcl}}\n"
|
9352 |
|
|
"{{All Files} *}\n"
|
9353 |
|
|
"}\n"
|
9354 |
|
|
"set f [tk_getOpenFile -filetypes $types -title \"TCL Script To Source...\"]\n"
|
9355 |
|
|
"if {$f!=\"\"} {\n"
|
9356 |
|
|
"uplevel #0 source $f\n"
|
9357 |
|
|
"}\n"
|
9358 |
|
|
"}\n"
|
9359 |
|
|
"proc console:SaveFile w {\n"
|
9360 |
|
|
"set types {\n"
|
9361 |
|
|
"{{Text Files} {.txt}}\n"
|
9362 |
|
|
"{{All Files} *}\n"
|
9363 |
|
|
"}\n"
|
9364 |
|
|
"set f [tk_getSaveFile -filetypes $types -title \"Write Screen To...\"]\n"
|
9365 |
|
|
"if {$f!=\"\"} {\n"
|
9366 |
|
|
"if {[catch {open $f w} fd]} {\n"
|
9367 |
|
|
"tk_messageBox -type ok -icon error -message $fd\n"
|
9368 |
|
|
"} else {\n"
|
9369 |
|
|
"puts $fd [string trimright [$w get 1.0 end] \\n]\n"
|
9370 |
|
|
"close $fd\n"
|
9371 |
|
|
"}\n"
|
9372 |
|
|
"}\n"
|
9373 |
|
|
"}\n"
|
9374 |
|
|
"proc console:Clear w {\n"
|
9375 |
|
|
"$w delete 1.0 {insert linestart}\n"
|
9376 |
|
|
"}\n"
|
9377 |
|
|
; /* End of the console code */
|
9378 |
|
|
#endif /* ET_ENABLE_TK */
|
9379 |
|
|
|
9380 |
|
|
/*
|
9381 |
|
|
** The "printf" code that follows dates from the 1980's. It is in
|
9382 |
|
|
** the public domain. The original comments are included here for
|
9383 |
|
|
** completeness. They are slightly out-of-date.
|
9384 |
|
|
**
|
9385 |
|
|
** The following modules is an enhanced replacement for the "printf" programs
|
9386 |
|
|
** found in the standard library. The following enhancements are
|
9387 |
|
|
** supported:
|
9388 |
|
|
**
|
9389 |
|
|
** + Additional functions. The standard set of "printf" functions
|
9390 |
|
|
** includes printf, fprintf, sprintf, vprintf, vfprintf, and
|
9391 |
|
|
** vsprintf. This module adds the following:
|
9392 |
|
|
**
|
9393 |
|
|
** * snprintf -- Works like sprintf, but has an extra argument
|
9394 |
|
|
** which is the size of the buffer written to.
|
9395 |
|
|
**
|
9396 |
|
|
** * mprintf -- Similar to sprintf. Writes output to memory
|
9397 |
|
|
** obtained from malloc.
|
9398 |
|
|
**
|
9399 |
|
|
** * xprintf -- Calls a function to dispose of output.
|
9400 |
|
|
**
|
9401 |
|
|
** * nprintf -- No output, but returns the number of characters
|
9402 |
|
|
** that would have been output by printf.
|
9403 |
|
|
**
|
9404 |
|
|
** * A v- version (ex: vsnprintf) of every function is also
|
9405 |
|
|
** supplied.
|
9406 |
|
|
**
|
9407 |
|
|
** + A few extensions to the formatting notation are supported:
|
9408 |
|
|
**
|
9409 |
|
|
** * The "=" flag (similar to "-") causes the output to be
|
9410 |
|
|
** be centered in the appropriately sized field.
|
9411 |
|
|
**
|
9412 |
|
|
** * The %b field outputs an integer in binary notation.
|
9413 |
|
|
**
|
9414 |
|
|
** * The %c field now accepts a precision. The character output
|
9415 |
|
|
** is repeated by the number of times the precision specifies.
|
9416 |
|
|
**
|
9417 |
|
|
** * The %' field works like %c, but takes as its character the
|
9418 |
|
|
** next character of the format string, instead of the next
|
9419 |
|
|
** argument. For example, printf("%.78'-") prints 78 minus
|
9420 |
|
|
** signs, the same as printf("%.78c",'-').
|
9421 |
|
|
**
|
9422 |
|
|
** + When compiled using GCC on a SPARC, this version of printf is
|
9423 |
|
|
** faster than the library printf for SUN OS 4.1.
|
9424 |
|
|
**
|
9425 |
|
|
** + All functions are fully reentrant.
|
9426 |
|
|
**
|
9427 |
|
|
*/
|
9428 |
|
|
/*
|
9429 |
|
|
** Undefine COMPATIBILITY to make some slight changes in the way things
|
9430 |
|
|
** work. I think the changes are an improvement, but they are not
|
9431 |
|
|
** backwards compatible.
|
9432 |
|
|
*/
|
9433 |
|
|
/* #define COMPATIBILITY / * Compatible with SUN OS 4.1 */
|
9434 |
|
|
|
9435 |
|
|
/*
|
9436 |
|
|
** Characters that need to be escaped inside a TCL string.
|
9437 |
|
|
*/
|
9438 |
|
|
static char NeedEsc[] = {
|
9439 |
|
|
1, 1, 1, 1, 1, 1, 1, 1, 'b', 't', 'n', 1, 'f', 'r', 1, 1,
|
9440 |
|
|
1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
|
9441 |
|
|
0, 0, '"', 0, '$', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
|
9442 |
|
|
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
|
9443 |
|
|
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
|
9444 |
|
|
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, '[','\\', ']', 0, 0,
|
9445 |
|
|
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
|
9446 |
|
|
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1, 0, 1,
|
9447 |
|
|
1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
|
9448 |
|
|
1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
|
9449 |
|
|
1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
|
9450 |
|
|
1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
|
9451 |
|
|
1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
|
9452 |
|
|
1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
|
9453 |
|
|
1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
|
9454 |
|
|
1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
|
9455 |
|
|
};
|
9456 |
|
|
|
9457 |
|
|
/*
|
9458 |
|
|
** Conversion types fall into various categories as defined by the
|
9459 |
|
|
** following enumeration.
|
9460 |
|
|
*/
|
9461 |
|
|
enum et_type { /* The type of the format field */
|
9462 |
|
|
etRADIX, /* Integer types. %d, %x, %o, and so forth */
|
9463 |
|
|
etFLOAT, /* Floating point. %f */
|
9464 |
|
|
etEXP, /* Exponentional notation. %e and %E */
|
9465 |
|
|
etGENERIC, /* Floating or exponential, depending on exponent. %g */
|
9466 |
|
|
etSIZE, /* Return number of characters processed so far. %n */
|
9467 |
|
|
etSTRING, /* Strings. %s */
|
9468 |
|
|
etPERCENT, /* Percent symbol. %% */
|
9469 |
|
|
etCHARX, /* Characters. %c */
|
9470 |
|
|
etERROR, /* Used to indicate no such conversion type */
|
9471 |
|
|
/* The rest are extensions, not normally found in printf() */
|
9472 |
|
|
etCHARLIT, /* Literal characters. %' */
|
9473 |
|
|
etTCLESCAPE, /* Strings with special characters escaped. %q */
|
9474 |
|
|
etMEMSTRING, /* A string which should be deleted after use. %z */
|
9475 |
|
|
etORDINAL /* 1st, 2nd, 3rd and so forth */
|
9476 |
|
|
};
|
9477 |
|
|
|
9478 |
|
|
/*
|
9479 |
|
|
** Each builtin conversion character (ex: the 'd' in "%d") is described
|
9480 |
|
|
** by an instance of the following structure
|
9481 |
|
|
*/
|
9482 |
|
|
typedef struct et_info { /* Information about each format field */
|
9483 |
|
|
int fmttype; /* The format field code letter */
|
9484 |
|
|
int base; /* The base for radix conversion */
|
9485 |
|
|
char *charset; /* The character set for conversion */
|
9486 |
|
|
int flag_signed; /* Is the quantity signed? */
|
9487 |
|
|
char *prefix; /* Prefix on non-zero values in alt format */
|
9488 |
|
|
enum et_type type; /* Conversion paradigm */
|
9489 |
|
|
} et_info;
|
9490 |
|
|
|
9491 |
|
|
/*
|
9492 |
|
|
** The following table is searched linearly, so it is good to put the
|
9493 |
|
|
** most frequently used conversion types first.
|
9494 |
|
|
*/
|
9495 |
|
|
static et_info fmtinfo[] = {
|
9496 |
|
|
{ 'd', 10, "0123456789", 1, 0, etRADIX, },
|
9497 |
|
|
{ 's', 0, 0, 0, 0, etSTRING, },
|
9498 |
|
|
{ 'q', 0, 0, 0, 0, etTCLESCAPE, },
|
9499 |
|
|
{ 'z', 0, 0, 0, 0, etMEMSTRING, },
|
9500 |
|
|
{ 'c', 0, 0, 0, 0, etCHARX, },
|
9501 |
|
|
{ 'o', 8, "01234567", 0, "0", etRADIX, },
|
9502 |
|
|
{ 'u', 10, "0123456789", 0, 0, etRADIX, },
|
9503 |
|
|
{ 'x', 16, "0123456789abcdef", 0, "x0", etRADIX, },
|
9504 |
|
|
{ 'X', 16, "0123456789ABCDEF", 0, "X0", etRADIX, },
|
9505 |
|
|
{ 'r', 10, "0123456789", 0, 0, etORDINAL, },
|
9506 |
|
|
{ 'f', 0, 0, 1, 0, etFLOAT, },
|
9507 |
|
|
{ 'e', 0, "e", 1, 0, etEXP, },
|
9508 |
|
|
{ 'E', 0, "E", 1, 0, etEXP, },
|
9509 |
|
|
{ 'g', 0, "e", 1, 0, etGENERIC, },
|
9510 |
|
|
{ 'G', 0, "E", 1, 0, etGENERIC, },
|
9511 |
|
|
{ 'i', 10, "0123456789", 1, 0, etRADIX, },
|
9512 |
|
|
{ 'n', 0, 0, 0, 0, etSIZE, },
|
9513 |
|
|
{ '%', 0, 0, 0, 0, etPERCENT, },
|
9514 |
|
|
{ 'b', 2, "01", 0, "b0", etRADIX, }, /* Binary */
|
9515 |
|
|
{ 'p', 10, "0123456789", 0, 0, etRADIX, }, /* Pointers */
|
9516 |
|
|
{ '\'', 0, 0, 0, 0, etCHARLIT, }, /* Literal char */
|
9517 |
|
|
};
|
9518 |
|
|
#define etNINFO (sizeof(fmtinfo)/sizeof(fmtinfo[0]))
|
9519 |
|
|
|
9520 |
|
|
/*
|
9521 |
|
|
** If NOFLOATINGPOINT is defined, then none of the floating point
|
9522 |
|
|
** conversions will work.
|
9523 |
|
|
*/
|
9524 |
|
|
#ifndef etNOFLOATINGPOINT
|
9525 |
|
|
/*
|
9526 |
|
|
** "*val" is a double such that 0.1 <= *val < 10.0
|
9527 |
|
|
** Return the ascii code for the leading digit of *val, then
|
9528 |
|
|
** multiply "*val" by 10.0 to renormalize.
|
9529 |
|
|
**
|
9530 |
|
|
** Example:
|
9531 |
|
|
** input: *val = 3.14159
|
9532 |
|
|
** output: *val = 1.4159 function return = '3'
|
9533 |
|
|
**
|
9534 |
|
|
** The counter *cnt is incremented each time. After counter exceeds
|
9535 |
|
|
** 16 (the number of significant digits in a 64-bit float) '0' is
|
9536 |
|
|
** always returned.
|
9537 |
|
|
*/
|
9538 |
|
|
static int et_getdigit(double *val, int *cnt){
|
9539 |
|
|
int digit;
|
9540 |
|
|
double d;
|
9541 |
|
|
if( (*cnt)++ >= 16 ) return '0';
|
9542 |
|
|
digit = (int)*val;
|
9543 |
|
|
d = digit;
|
9544 |
|
|
digit += '0';
|
9545 |
|
|
*val = (*val - d)*10.0;
|
9546 |
|
|
return digit;
|
9547 |
|
|
}
|
9548 |
|
|
#endif
|
9549 |
|
|
|
9550 |
|
|
#define etBUFSIZE 1000 /* Size of the output buffer */
|
9551 |
|
|
|
9552 |
|
|
/*
|
9553 |
|
|
** The root program. All variations call this core.
|
9554 |
|
|
**
|
9555 |
|
|
** INPUTS:
|
9556 |
|
|
** func This is a pointer to a function taking three arguments
|
9557 |
|
|
** 1. A pointer to anything. Same as the "arg" parameter.
|
9558 |
|
|
** 2. A pointer to the list of characters to be output
|
9559 |
|
|
** (Note, this list is NOT null terminated.)
|
9560 |
|
|
** 3. An integer number of characters to be output.
|
9561 |
|
|
** (Note: This number might be zero.)
|
9562 |
|
|
**
|
9563 |
|
|
** arg This is the pointer to anything which will be passed as the
|
9564 |
|
|
** first argument to "func". Use it for whatever you like.
|
9565 |
|
|
**
|
9566 |
|
|
** fmt This is the format string, as in the usual print.
|
9567 |
|
|
**
|
9568 |
|
|
** ap This is a pointer to a list of arguments. Same as in
|
9569 |
|
|
** vfprint.
|
9570 |
|
|
**
|
9571 |
|
|
** OUTPUTS:
|
9572 |
|
|
** The return value is the total number of characters sent to
|
9573 |
|
|
** the function "func". Returns -1 on a error.
|
9574 |
|
|
**
|
9575 |
|
|
** Note that the order in which automatic variables are declared below
|
9576 |
|
|
** seems to make a big difference in determining how fast this beast
|
9577 |
|
|
** will run.
|
9578 |
|
|
*/
|
9579 |
|
|
int vxprintf(
|
9580 |
|
|
void (*func)(void*,char*,int),
|
9581 |
|
|
void *arg,
|
9582 |
|
|
const char *format,
|
9583 |
|
|
va_list ap
|
9584 |
|
|
){
|
9585 |
|
|
register const char *fmt; /* The format string. */
|
9586 |
|
|
register int c; /* Next character in the format string */
|
9587 |
|
|
register char *bufpt; /* Pointer to the conversion buffer */
|
9588 |
|
|
register int precision; /* Precision of the current field */
|
9589 |
|
|
register int length; /* Length of the field */
|
9590 |
|
|
register int idx; /* A general purpose loop counter */
|
9591 |
|
|
int count; /* Total number of characters output */
|
9592 |
|
|
int width; /* Width of the current field */
|
9593 |
|
|
int flag_leftjustify; /* True if "-" flag is present */
|
9594 |
|
|
int flag_plussign; /* True if "+" flag is present */
|
9595 |
|
|
int flag_blanksign; /* True if " " flag is present */
|
9596 |
|
|
int flag_alternateform; /* True if "#" flag is present */
|
9597 |
|
|
int flag_zeropad; /* True if field width constant starts with zero */
|
9598 |
|
|
int flag_long; /* True if "l" flag is present */
|
9599 |
|
|
int flag_center; /* True if "=" flag is present */
|
9600 |
|
|
unsigned long longvalue; /* Value for integer types */
|
9601 |
|
|
double realvalue; /* Value for real types */
|
9602 |
|
|
et_info *infop; /* Pointer to the appropriate info structure */
|
9603 |
|
|
char buf[etBUFSIZE]; /* Conversion buffer */
|
9604 |
|
|
char prefix; /* Prefix character. "+" or "-" or " " or '\0'. */
|
9605 |
|
|
int errorflag = 0; /* True if an error is encountered */
|
9606 |
|
|
enum et_type xtype; /* Conversion paradigm */
|
9607 |
|
|
char *zMem; /* String to be freed */
|
9608 |
|
|
char *zExtra; /* Extra memory used for etTCLESCAPE conversions */
|
9609 |
|
|
static char spaces[] = " "
|
9610 |
|
|
" ";
|
9611 |
|
|
#define etSPACESIZE (sizeof(spaces)-1)
|
9612 |
|
|
#ifndef etNOFLOATINGPOINT
|
9613 |
|
|
int exp; /* exponent of real numbers */
|
9614 |
|
|
double rounder; /* Used for rounding floating point values */
|
9615 |
|
|
int flag_dp; /* True if decimal point should be shown */
|
9616 |
|
|
int flag_rtz; /* True if trailing zeros should be removed */
|
9617 |
|
|
int flag_exp; /* True to force display of the exponent */
|
9618 |
|
|
int nsd; /* Number of significant digits returned */
|
9619 |
|
|
#endif
|
9620 |
|
|
|
9621 |
|
|
fmt = format; /* Put in a register for speed */
|
9622 |
|
|
count = length = 0;
|
9623 |
|
|
bufpt = 0;
|
9624 |
|
|
for(; (c=(*fmt))!=0; ++fmt){
|
9625 |
|
|
if( c!='%' ){
|
9626 |
|
|
register int amt;
|
9627 |
|
|
bufpt = (char *)fmt;
|
9628 |
|
|
amt = 1;
|
9629 |
|
|
while( (c=(*++fmt))!='%' && c!=0 ) amt++;
|
9630 |
|
|
(*func)(arg,bufpt,amt);
|
9631 |
|
|
count += amt;
|
9632 |
|
|
if( c==0 ) break;
|
9633 |
|
|
}
|
9634 |
|
|
if( (c=(*++fmt))==0 ){
|
9635 |
|
|
errorflag = 1;
|
9636 |
|
|
(*func)(arg,"%",1);
|
9637 |
|
|
count++;
|
9638 |
|
|
break;
|
9639 |
|
|
}
|
9640 |
|
|
/* Find out what flags are present */
|
9641 |
|
|
flag_leftjustify = flag_plussign = flag_blanksign =
|
9642 |
|
|
flag_alternateform = flag_zeropad = flag_center = 0;
|
9643 |
|
|
do{
|
9644 |
|
|
switch( c ){
|
9645 |
|
|
case '-': flag_leftjustify = 1; c = 0; break;
|
9646 |
|
|
case '+': flag_plussign = 1; c = 0; break;
|
9647 |
|
|
case ' ': flag_blanksign = 1; c = 0; break;
|
9648 |
|
|
case '#': flag_alternateform = 1; c = 0; break;
|
9649 |
|
|
case '0': flag_zeropad = 1; c = 0; break;
|
9650 |
|
|
case '=': flag_center = 1; c = 0; break;
|
9651 |
|
|
default: break;
|
9652 |
|
|
}
|
9653 |
|
|
}while( c==0 && (c=(*++fmt))!=0 );
|
9654 |
|
|
if( flag_center ) flag_leftjustify = 0;
|
9655 |
|
|
/* Get the field width */
|
9656 |
|
|
width = 0;
|
9657 |
|
|
if( c=='*' ){
|
9658 |
|
|
width = va_arg(ap,int);
|
9659 |
|
|
if( width<0 ){
|
9660 |
|
|
flag_leftjustify = 1;
|
9661 |
|
|
width = -width;
|
9662 |
|
|
}
|
9663 |
|
|
c = *++fmt;
|
9664 |
|
|
}else{
|
9665 |
|
|
while( isdigit(c) ){
|
9666 |
|
|
width = width*10 + c - '0';
|
9667 |
|
|
c = *++fmt;
|
9668 |
|
|
}
|
9669 |
|
|
}
|
9670 |
|
|
if( width > etBUFSIZE-10 ){
|
9671 |
|
|
width = etBUFSIZE-10;
|
9672 |
|
|
}
|
9673 |
|
|
/* Get the precision */
|
9674 |
|
|
if( c=='.' ){
|
9675 |
|
|
precision = 0;
|
9676 |
|
|
c = *++fmt;
|
9677 |
|
|
if( c=='*' ){
|
9678 |
|
|
precision = va_arg(ap,int);
|
9679 |
|
|
#ifndef etCOMPATIBILITY
|
9680 |
|
|
/* This is sensible, but SUN OS 4.1 doesn't do it. */
|
9681 |
|
|
if( precision<0 ) precision = -precision;
|
9682 |
|
|
#endif
|
9683 |
|
|
c = *++fmt;
|
9684 |
|
|
}else{
|
9685 |
|
|
while( isdigit(c) ){
|
9686 |
|
|
precision = precision*10 + c - '0';
|
9687 |
|
|
c = *++fmt;
|
9688 |
|
|
}
|
9689 |
|
|
}
|
9690 |
|
|
/* Limit the precision to prevent overflowing buf[] during conversion */
|
9691 |
|
|
if( precision>etBUFSIZE-40 ) precision = etBUFSIZE-40;
|
9692 |
|
|
}else{
|
9693 |
|
|
precision = -1;
|
9694 |
|
|
}
|
9695 |
|
|
/* Get the conversion type modifier */
|
9696 |
|
|
if( c=='l' ){
|
9697 |
|
|
flag_long = 1;
|
9698 |
|
|
c = *++fmt;
|
9699 |
|
|
}else{
|
9700 |
|
|
flag_long = 0;
|
9701 |
|
|
}
|
9702 |
|
|
/* Fetch the info entry for the field */
|
9703 |
|
|
infop = 0;
|
9704 |
|
|
for(idx=0; idx<etNINFO; idx++){
|
9705 |
|
|
if( c==fmtinfo[idx].fmttype ){
|
9706 |
|
|
infop = &fmtinfo[idx];
|
9707 |
|
|
break;
|
9708 |
|
|
}
|
9709 |
|
|
}
|
9710 |
|
|
/* No info entry found. It must be an error. */
|
9711 |
|
|
if( infop==0 ){
|
9712 |
|
|
xtype = etERROR;
|
9713 |
|
|
}else{
|
9714 |
|
|
xtype = infop->type;
|
9715 |
|
|
}
|
9716 |
|
|
zExtra = 0;
|
9717 |
|
|
|
9718 |
|
|
/*
|
9719 |
|
|
** At this point, variables are initialized as follows:
|
9720 |
|
|
**
|
9721 |
|
|
** flag_alternateform TRUE if a '#' is present.
|
9722 |
|
|
** flag_plussign TRUE if a '+' is present.
|
9723 |
|
|
** flag_leftjustify TRUE if a '-' is present or if the
|
9724 |
|
|
** field width was negative.
|
9725 |
|
|
** flag_zeropad TRUE if the width began with 0.
|
9726 |
|
|
** flag_long TRUE if the letter 'l' (ell) prefixed
|
9727 |
|
|
** the conversion character.
|
9728 |
|
|
** flag_blanksign TRUE if a ' ' is present.
|
9729 |
|
|
** width The specified field width. This is
|
9730 |
|
|
** always non-negative. Zero is the default.
|
9731 |
|
|
** precision The specified precision. The default
|
9732 |
|
|
** is -1.
|
9733 |
|
|
** xtype The class of the conversion.
|
9734 |
|
|
** infop Pointer to the appropriate info struct.
|
9735 |
|
|
*/
|
9736 |
|
|
switch( xtype ){
|
9737 |
|
|
case etORDINAL:
|
9738 |
|
|
case etRADIX:
|
9739 |
|
|
if( flag_long ) longvalue = va_arg(ap,long);
|
9740 |
|
|
else longvalue = va_arg(ap,int);
|
9741 |
|
|
#ifdef etCOMPATIBILITY
|
9742 |
|
|
/* For the format %#x, the value zero is printed "0" not "0x0".
|
9743 |
|
|
** I think this is stupid. */
|
9744 |
|
|
if( longvalue==0 ) flag_alternateform = 0;
|
9745 |
|
|
#else
|
9746 |
|
|
/* More sensible: turn off the prefix for octal (to prevent "00"),
|
9747 |
|
|
** but leave the prefix for hex. */
|
9748 |
|
|
if( longvalue==0 && infop->base==8 ) flag_alternateform = 0;
|
9749 |
|
|
#endif
|
9750 |
|
|
if( infop->flag_signed ){
|
9751 |
|
|
if( *(long*)&longvalue<0 ){
|
9752 |
|
|
longvalue = -*(long*)&longvalue;
|
9753 |
|
|
prefix = '-';
|
9754 |
|
|
}else if( flag_plussign ) prefix = '+';
|
9755 |
|
|
else if( flag_blanksign ) prefix = ' ';
|
9756 |
|
|
else prefix = 0;
|
9757 |
|
|
}else prefix = 0;
|
9758 |
|
|
if( flag_zeropad && precision<width-(prefix!=0) ){
|
9759 |
|
|
precision = width-(prefix!=0);
|
9760 |
|
|
}
|
9761 |
|
|
bufpt = &buf[etBUFSIZE];
|
9762 |
|
|
if( xtype==etORDINAL ){
|
9763 |
|
|
long a,b;
|
9764 |
|
|
a = longvalue%10;
|
9765 |
|
|
b = longvalue%100;
|
9766 |
|
|
bufpt -= 2;
|
9767 |
|
|
if( a==0 || a>3 || (b>10 && b<14) ){
|
9768 |
|
|
bufpt[0] = 't';
|
9769 |
|
|
bufpt[1] = 'h';
|
9770 |
|
|
}else if( a==1 ){
|
9771 |
|
|
bufpt[0] = 's';
|
9772 |
|
|
bufpt[1] = 't';
|
9773 |
|
|
}else if( a==2 ){
|
9774 |
|
|
bufpt[0] = 'n';
|
9775 |
|
|
bufpt[1] = 'd';
|
9776 |
|
|
}else if( a==3 ){
|
9777 |
|
|
bufpt[0] = 'r';
|
9778 |
|
|
bufpt[1] = 'd';
|
9779 |
|
|
}
|
9780 |
|
|
}
|
9781 |
|
|
{
|
9782 |
|
|
register char *cset; /* Use registers for speed */
|
9783 |
|
|
register int base;
|
9784 |
|
|
cset = infop->charset;
|
9785 |
|
|
base = infop->base;
|
9786 |
|
|
do{ /* Convert to ascii */
|
9787 |
|
|
*(--bufpt) = cset[longvalue%base];
|
9788 |
|
|
longvalue = longvalue/base;
|
9789 |
|
|
}while( longvalue>0 );
|
9790 |
|
|
}
|
9791 |
|
|
length = (long)&buf[etBUFSIZE]-(long)bufpt;
|
9792 |
|
|
for(idx=precision-length; idx>0; idx--){
|
9793 |
|
|
*(--bufpt) = '0'; /* Zero pad */
|
9794 |
|
|
}
|
9795 |
|
|
if( prefix ) *(--bufpt) = prefix; /* Add sign */
|
9796 |
|
|
if( flag_alternateform && infop->prefix ){ /* Add "0" or "0x" */
|
9797 |
|
|
char *pre, x;
|
9798 |
|
|
pre = infop->prefix;
|
9799 |
|
|
if( *bufpt!=pre[0] ){
|
9800 |
|
|
for(pre=infop->prefix; (x=(*pre))!=0; pre++) *(--bufpt) = x;
|
9801 |
|
|
}
|
9802 |
|
|
}
|
9803 |
|
|
length = (long)&buf[etBUFSIZE]-(long)bufpt;
|
9804 |
|
|
break;
|
9805 |
|
|
case etFLOAT:
|
9806 |
|
|
case etEXP:
|
9807 |
|
|
case etGENERIC:
|
9808 |
|
|
realvalue = va_arg(ap,double);
|
9809 |
|
|
#ifndef etNOFLOATINGPOINT
|
9810 |
|
|
if( precision<0 ) precision = 6; /* Set default precision */
|
9811 |
|
|
if( precision>etBUFSIZE-10 ) precision = etBUFSIZE-10;
|
9812 |
|
|
if( realvalue<0.0 ){
|
9813 |
|
|
realvalue = -realvalue;
|
9814 |
|
|
prefix = '-';
|
9815 |
|
|
}else{
|
9816 |
|
|
if( flag_plussign ) prefix = '+';
|
9817 |
|
|
else if( flag_blanksign ) prefix = ' ';
|
9818 |
|
|
else prefix = 0;
|
9819 |
|
|
}
|
9820 |
|
|
if( infop->type==etGENERIC && precision>0 ) precision--;
|
9821 |
|
|
rounder = 0.0;
|
9822 |
|
|
#ifdef COMPATIBILITY
|
9823 |
|
|
/* Rounding works like BSD when the constant 0.4999 is used. Wierd! */
|
9824 |
|
|
for(idx=precision, rounder=0.4999; idx>0; idx--, rounder*=0.1);
|
9825 |
|
|
#else
|
9826 |
|
|
/* It makes more sense to use 0.5 */
|
9827 |
|
|
for(idx=precision, rounder=0.5; idx>0; idx--, rounder*=0.1);
|
9828 |
|
|
#endif
|
9829 |
|
|
if( infop->type==etFLOAT ) realvalue += rounder;
|
9830 |
|
|
/* Normalize realvalue to within 10.0 > realvalue >= 1.0 */
|
9831 |
|
|
exp = 0;
|
9832 |
|
|
if( realvalue>0.0 ){
|
9833 |
|
|
int k = 0;
|
9834 |
|
|
while( realvalue>=1e8 && k++<100 ){ realvalue *= 1e-8; exp+=8; }
|
9835 |
|
|
while( realvalue>=10.0 && k++<100 ){ realvalue *= 0.1; exp++; }
|
9836 |
|
|
while( realvalue<1e-8 && k++<100 ){ realvalue *= 1e8; exp-=8; }
|
9837 |
|
|
while( realvalue<1.0 && k++<100 ){ realvalue *= 10.0; exp--; }
|
9838 |
|
|
if( k>=100 ){
|
9839 |
|
|
bufpt = "NaN";
|
9840 |
|
|
length = 3;
|
9841 |
|
|
break;
|
9842 |
|
|
}
|
9843 |
|
|
}
|
9844 |
|
|
bufpt = buf;
|
9845 |
|
|
/*
|
9846 |
|
|
** If the field type is etGENERIC, then convert to either etEXP
|
9847 |
|
|
** or etFLOAT, as appropriate.
|
9848 |
|
|
*/
|
9849 |
|
|
flag_exp = xtype==etEXP;
|
9850 |
|
|
if( xtype!=etFLOAT ){
|
9851 |
|
|
realvalue += rounder;
|
9852 |
|
|
if( realvalue>=10.0 ){ realvalue *= 0.1; exp++; }
|
9853 |
|
|
}
|
9854 |
|
|
if( xtype==etGENERIC ){
|
9855 |
|
|
flag_rtz = !flag_alternateform;
|
9856 |
|
|
if( exp<-4 || exp>precision ){
|
9857 |
|
|
xtype = etEXP;
|
9858 |
|
|
}else{
|
9859 |
|
|
precision = precision - exp;
|
9860 |
|
|
xtype = etFLOAT;
|
9861 |
|
|
}
|
9862 |
|
|
}else{
|
9863 |
|
|
flag_rtz = 0;
|
9864 |
|
|
}
|
9865 |
|
|
/*
|
9866 |
|
|
** The "exp+precision" test causes output to be of type etEXP if
|
9867 |
|
|
** the precision is too large to fit in buf[].
|
9868 |
|
|
*/
|
9869 |
|
|
nsd = 0;
|
9870 |
|
|
if( xtype==etFLOAT && exp+precision<etBUFSIZE-30 ){
|
9871 |
|
|
flag_dp = (precision>0 || flag_alternateform);
|
9872 |
|
|
if( prefix ) *(bufpt++) = prefix; /* Sign */
|
9873 |
|
|
if( exp<0 ) *(bufpt++) = '0'; /* Digits before "." */
|
9874 |
|
|
else for(; exp>=0; exp--) *(bufpt++) = et_getdigit(&realvalue,&nsd);
|
9875 |
|
|
if( flag_dp ) *(bufpt++) = '.'; /* The decimal point */
|
9876 |
|
|
for(exp++; exp<0 && precision>0; precision--, exp++){
|
9877 |
|
|
*(bufpt++) = '0';
|
9878 |
|
|
}
|
9879 |
|
|
while( (precision--)>0 ) *(bufpt++) = et_getdigit(&realvalue,&nsd);
|
9880 |
|
|
*(bufpt--) = 0; /* Null terminate */
|
9881 |
|
|
if( flag_rtz && flag_dp ){ /* Remove trailing zeros and "." */
|
9882 |
|
|
while( bufpt>=buf && *bufpt=='0' ) *(bufpt--) = 0;
|
9883 |
|
|
if( bufpt>=buf && *bufpt=='.' ) *(bufpt--) = 0;
|
9884 |
|
|
}
|
9885 |
|
|
bufpt++; /* point to next free slot */
|
9886 |
|
|
}else{ /* etEXP or etGENERIC */
|
9887 |
|
|
flag_dp = (precision>0 || flag_alternateform);
|
9888 |
|
|
if( prefix ) *(bufpt++) = prefix; /* Sign */
|
9889 |
|
|
*(bufpt++) = et_getdigit(&realvalue,&nsd); /* First digit */
|
9890 |
|
|
if( flag_dp ) *(bufpt++) = '.'; /* Decimal point */
|
9891 |
|
|
while( (precision--)>0 ) *(bufpt++) = et_getdigit(&realvalue,&nsd);
|
9892 |
|
|
bufpt--; /* point to last digit */
|
9893 |
|
|
if( flag_rtz && flag_dp ){ /* Remove tail zeros */
|
9894 |
|
|
while( bufpt>=buf && *bufpt=='0' ) *(bufpt--) = 0;
|
9895 |
|
|
if( bufpt>=buf && *bufpt=='.' ) *(bufpt--) = 0;
|
9896 |
|
|
}
|
9897 |
|
|
bufpt++; /* point to next free slot */
|
9898 |
|
|
if( exp || flag_exp ){
|
9899 |
|
|
*(bufpt++) = infop->charset[0];
|
9900 |
|
|
if( exp<0 ){ *(bufpt++) = '-'; exp = -exp; } /* sign of exp */
|
9901 |
|
|
else { *(bufpt++) = '+'; }
|
9902 |
|
|
if( exp>=100 ){
|
9903 |
|
|
*(bufpt++) = (exp/100)+'0'; /* 100's digit */
|
9904 |
|
|
exp %= 100;
|
9905 |
|
|
}
|
9906 |
|
|
*(bufpt++) = exp/10+'0'; /* 10's digit */
|
9907 |
|
|
*(bufpt++) = exp%10+'0'; /* 1's digit */
|
9908 |
|
|
}
|
9909 |
|
|
}
|
9910 |
|
|
/* The converted number is in buf[] and zero terminated. Output it.
|
9911 |
|
|
** Note that the number is in the usual order, not reversed as with
|
9912 |
|
|
** integer conversions. */
|
9913 |
|
|
length = (long)bufpt-(long)buf;
|
9914 |
|
|
bufpt = buf;
|
9915 |
|
|
|
9916 |
|
|
/* Special case: Add leading zeros if the flag_zeropad flag is
|
9917 |
|
|
** set and we are not left justified */
|
9918 |
|
|
if( flag_zeropad && !flag_leftjustify && length < width){
|
9919 |
|
|
int i;
|
9920 |
|
|
int nPad = width - length;
|
9921 |
|
|
for(i=width; i>=nPad; i--){
|
9922 |
|
|
bufpt[i] = bufpt[i-nPad];
|
9923 |
|
|
}
|
9924 |
|
|
i = prefix!=0;
|
9925 |
|
|
while( nPad-- ) bufpt[i++] = '0';
|
9926 |
|
|
length = width;
|
9927 |
|
|
}
|
9928 |
|
|
#endif
|
9929 |
|
|
break;
|
9930 |
|
|
case etSIZE:
|
9931 |
|
|
*(va_arg(ap,int*)) = count;
|
9932 |
|
|
length = width = 0;
|
9933 |
|
|
break;
|
9934 |
|
|
case etPERCENT:
|
9935 |
|
|
buf[0] = '%';
|
9936 |
|
|
bufpt = buf;
|
9937 |
|
|
length = 1;
|
9938 |
|
|
break;
|
9939 |
|
|
case etCHARLIT:
|
9940 |
|
|
case etCHARX:
|
9941 |
|
|
c = buf[0] = (xtype==etCHARX ? va_arg(ap,int) : *++fmt);
|
9942 |
|
|
if( precision>=0 ){
|
9943 |
|
|
for(idx=1; idx<precision; idx++) buf[idx] = c;
|
9944 |
|
|
length = precision;
|
9945 |
|
|
}else{
|
9946 |
|
|
length =1;
|
9947 |
|
|
}
|
9948 |
|
|
bufpt = buf;
|
9949 |
|
|
break;
|
9950 |
|
|
case etSTRING:
|
9951 |
|
|
case etMEMSTRING:
|
9952 |
|
|
zMem = bufpt = va_arg(ap,char*);
|
9953 |
|
|
if( bufpt==0 ) bufpt = "(null)";
|
9954 |
|
|
length = strlen(bufpt);
|
9955 |
|
|
if( precision>=0 && precision<length ) length = precision;
|
9956 |
|
|
break;
|
9957 |
|
|
case etTCLESCAPE:
|
9958 |
|
|
{
|
9959 |
|
|
int i, j, n, c, k;
|
9960 |
|
|
char *arg = va_arg(ap,char*);
|
9961 |
|
|
if( arg==0 ) arg = "(NULL)";
|
9962 |
|
|
for(i=n=0; (c=arg[i])!=0; i++){
|
9963 |
|
|
k = NeedEsc[c&0xff];
|
9964 |
|
|
if( k==0 ){
|
9965 |
|
|
n++;
|
9966 |
|
|
}else if( k==1 ){
|
9967 |
|
|
n+=4;
|
9968 |
|
|
}else{
|
9969 |
|
|
n+=2;
|
9970 |
|
|
}
|
9971 |
|
|
}
|
9972 |
|
|
n++;
|
9973 |
|
|
if( n>etBUFSIZE ){
|
9974 |
|
|
bufpt = zExtra = Tcl_Alloc( n );
|
9975 |
|
|
}else{
|
9976 |
|
|
bufpt = buf;
|
9977 |
|
|
}
|
9978 |
|
|
for(i=j=0; (c=arg[i])!=0; i++){
|
9979 |
|
|
k = NeedEsc[c&0xff];
|
9980 |
|
|
if( k==0 ){
|
9981 |
|
|
bufpt[j++] = c;
|
9982 |
|
|
}else if( k==1 ){
|
9983 |
|
|
bufpt[j++] = '\\';
|
9984 |
|
|
bufpt[j++] = ((c>>6) & 3) + '0';
|
9985 |
|
|
bufpt[j++] = ((c>>3) & 7) + '0';
|
9986 |
|
|
bufpt[j++] = (c & 7) + '0';
|
9987 |
|
|
}else{
|
9988 |
|
|
bufpt[j++] = '\\';
|
9989 |
|
|
bufpt[j++] = k;
|
9990 |
|
|
}
|
9991 |
|
|
}
|
9992 |
|
|
bufpt[j] = 0;
|
9993 |
|
|
length = j;
|
9994 |
|
|
if( precision>=0 && precision<length ) length = precision;
|
9995 |
|
|
}
|
9996 |
|
|
break;
|
9997 |
|
|
case etERROR:
|
9998 |
|
|
buf[0] = '%';
|
9999 |
|
|
buf[1] = c;
|
10000 |
|
|
errorflag = 0;
|
10001 |
|
|
idx = 1+(c!=0);
|
10002 |
|
|
(*func)(arg,"%",idx);
|
10003 |
|
|
count += idx;
|
10004 |
|
|
if( c==0 ) fmt--;
|
10005 |
|
|
break;
|
10006 |
|
|
}/* End switch over the format type */
|
10007 |
|
|
/*
|
10008 |
|
|
** The text of the conversion is pointed to by "bufpt" and is
|
10009 |
|
|
** "length" characters long. The field width is "width". Do
|
10010 |
|
|
** the output.
|
10011 |
|
|
*/
|
10012 |
|
|
if( !flag_leftjustify ){
|
10013 |
|
|
register int nspace;
|
10014 |
|
|
nspace = width-length;
|
10015 |
|
|
if( nspace>0 ){
|
10016 |
|
|
if( flag_center ){
|
10017 |
|
|
nspace = nspace/2;
|
10018 |
|
|
width -= nspace;
|
10019 |
|
|
flag_leftjustify = 1;
|
10020 |
|
|
}
|
10021 |
|
|
count += nspace;
|
10022 |
|
|
while( nspace>=etSPACESIZE ){
|
10023 |
|
|
(*func)(arg,spaces,etSPACESIZE);
|
10024 |
|
|
nspace -= etSPACESIZE;
|
10025 |
|
|
}
|
10026 |
|
|
if( nspace>0 ) (*func)(arg,spaces,nspace);
|
10027 |
|
|
}
|
10028 |
|
|
}
|
10029 |
|
|
if( length>0 ){
|
10030 |
|
|
(*func)(arg,bufpt,length);
|
10031 |
|
|
count += length;
|
10032 |
|
|
}
|
10033 |
|
|
if( xtype==etMEMSTRING && zMem ){
|
10034 |
|
|
Tcl_Free(zMem);
|
10035 |
|
|
}
|
10036 |
|
|
if( flag_leftjustify ){
|
10037 |
|
|
register int nspace;
|
10038 |
|
|
nspace = width-length;
|
10039 |
|
|
if( nspace>0 ){
|
10040 |
|
|
count += nspace;
|
10041 |
|
|
while( nspace>=etSPACESIZE ){
|
10042 |
|
|
(*func)(arg,spaces,etSPACESIZE);
|
10043 |
|
|
nspace -= etSPACESIZE;
|
10044 |
|
|
}
|
10045 |
|
|
if( nspace>0 ) (*func)(arg,spaces,nspace);
|
10046 |
|
|
}
|
10047 |
|
|
}
|
10048 |
|
|
if( zExtra ){
|
10049 |
|
|
Tcl_Free(zExtra);
|
10050 |
|
|
}
|
10051 |
|
|
}/* End for loop over the format string */
|
10052 |
|
|
return errorflag ? -1 : count;
|
10053 |
|
|
} /* End of function */
|
10054 |
|
|
|
10055 |
|
|
/*
|
10056 |
|
|
** The following section of code handles the mprintf routine, that
|
10057 |
|
|
** writes to memory obtained from malloc().
|
10058 |
|
|
*/
|
10059 |
|
|
|
10060 |
|
|
/* This structure is used to store state information about the
|
10061 |
|
|
** write to memory that is currently in progress.
|
10062 |
|
|
*/
|
10063 |
|
|
struct sgMprintf {
|
10064 |
|
|
char *zBase; /* A base allocation */
|
10065 |
|
|
char *zText; /* The string collected so far */
|
10066 |
|
|
int nChar; /* Length of the string so far */
|
10067 |
|
|
int nAlloc; /* Amount of space allocated in zText */
|
10068 |
|
|
};
|
10069 |
|
|
|
10070 |
|
|
/*
|
10071 |
|
|
** The xprintf callback function.
|
10072 |
|
|
**
|
10073 |
|
|
** This routine add nNewChar characters of text in zNewText to
|
10074 |
|
|
** the sgMprintf structure pointed to by "arg".
|
10075 |
|
|
*/
|
10076 |
|
|
static void mout(void *arg, char *zNewText, int nNewChar){
|
10077 |
|
|
struct sgMprintf *pM = (struct sgMprintf*)arg;
|
10078 |
|
|
if( pM->nChar + nNewChar + 1 > pM->nAlloc ){
|
10079 |
|
|
pM->nAlloc = pM->nChar + nNewChar*2 + 1;
|
10080 |
|
|
if( pM->zText==pM->zBase ){
|
10081 |
|
|
pM->zText = Tcl_Alloc(pM->nAlloc);
|
10082 |
|
|
if( pM->zText && pM->nChar ) memcpy(pM->zText,pM->zBase,pM->nChar);
|
10083 |
|
|
}else{
|
10084 |
|
|
pM->zText = Tcl_Realloc(pM->zText, pM->nAlloc);
|
10085 |
|
|
}
|
10086 |
|
|
}
|
10087 |
|
|
if( pM->zText ){
|
10088 |
|
|
memcpy(&pM->zText[pM->nChar], zNewText, nNewChar);
|
10089 |
|
|
pM->nChar += nNewChar;
|
10090 |
|
|
pM->zText[pM->nChar] = 0;
|
10091 |
|
|
}
|
10092 |
|
|
}
|
10093 |
|
|
|
10094 |
|
|
/*
|
10095 |
|
|
** mprintf() works like printf(), but allocations memory to hold the
|
10096 |
|
|
** resulting string and returns a pointer to the allocated memory.
|
10097 |
|
|
*/
|
10098 |
|
|
char *mprintf(const char *zFormat, ...){
|
10099 |
|
|
va_list ap;
|
10100 |
|
|
struct sgMprintf sMprintf;
|
10101 |
|
|
char *zNew;
|
10102 |
|
|
char zBuf[200];
|
10103 |
|
|
|
10104 |
|
|
sMprintf.nChar = 0;
|
10105 |
|
|
sMprintf.nAlloc = sizeof(zBuf);
|
10106 |
|
|
sMprintf.zText = zBuf;
|
10107 |
|
|
sMprintf.zBase = zBuf;
|
10108 |
|
|
va_start(ap,zFormat);
|
10109 |
|
|
vxprintf(mout,&sMprintf,zFormat,ap);
|
10110 |
|
|
va_end(ap);
|
10111 |
|
|
sMprintf.zText[sMprintf.nChar] = 0;
|
10112 |
|
|
if( sMprintf.zText==sMprintf.zBase ){
|
10113 |
|
|
zNew = Tcl_Alloc( sMprintf.nChar+1 );
|
10114 |
|
|
if( zNew ) strcpy(zNew,zBuf);
|
10115 |
|
|
}else{
|
10116 |
|
|
zNew = Tcl_Realloc(sMprintf.zText,sMprintf.nChar+1);
|
10117 |
|
|
}
|
10118 |
|
|
return zNew;
|
10119 |
|
|
}
|
10120 |
|
|
|
10121 |
|
|
/* This is the varargs version of mprintf.
|
10122 |
|
|
*/
|
10123 |
|
|
char *vmprintf(const char *zFormat, va_list ap){
|
10124 |
|
|
struct sgMprintf sMprintf;
|
10125 |
|
|
char zBuf[200];
|
10126 |
|
|
sMprintf.nChar = 0;
|
10127 |
|
|
sMprintf.zText = zBuf;
|
10128 |
|
|
sMprintf.nAlloc = sizeof(zBuf);
|
10129 |
|
|
sMprintf.zBase = zBuf;
|
10130 |
|
|
vxprintf(mout,&sMprintf,zFormat,ap);
|
10131 |
|
|
sMprintf.zText[sMprintf.nChar] = 0;
|
10132 |
|
|
if( sMprintf.zText==sMprintf.zBase ){
|
10133 |
|
|
sMprintf.zText = Tcl_Alloc( strlen(zBuf)+1 );
|
10134 |
|
|
if( sMprintf.zText ) strcpy(sMprintf.zText,zBuf);
|
10135 |
|
|
}else{
|
10136 |
|
|
sMprintf.zText = Tcl_Realloc(sMprintf.zText,sMprintf.nChar+1);
|
10137 |
|
|
}
|
10138 |
|
|
return sMprintf.zText;
|
10139 |
|
|
}
|
10140 |
|
|
|
10141 |
|
|
/*
|
10142 |
|
|
** Add text output to a Tcl_DString.
|
10143 |
|
|
**
|
10144 |
|
|
** This routine is called by vxprintf(). It's job is to add
|
10145 |
|
|
** nNewChar characters of text from zNewText to the Tcl_DString
|
10146 |
|
|
** that "arg" is pointing to.
|
10147 |
|
|
*/
|
10148 |
|
|
static void dstringout(void *arg, char *zNewText, int nNewChar){
|
10149 |
|
|
Tcl_DString *str = (Tcl_DString*)arg;
|
10150 |
|
|
Tcl_DStringAppend(str,zNewText,nNewChar);
|
10151 |
|
|
}
|
10152 |
|
|
|
10153 |
|
|
/*
|
10154 |
|
|
** Append formatted output to a DString.
|
10155 |
|
|
*/
|
10156 |
|
|
char *Et_DStringAppendF(Tcl_DString *str, const char *zFormat, ...){
|
10157 |
|
|
va_list ap;
|
10158 |
|
|
va_start(ap,zFormat);
|
10159 |
|
|
vxprintf(dstringout,str,zFormat,ap);
|
10160 |
|
|
va_end(ap);
|
10161 |
|
|
return Tcl_DStringValue(str);
|
10162 |
|
|
}
|
10163 |
|
|
|
10164 |
|
|
/*
|
10165 |
|
|
** Make this variable true to trace all calls to EvalF
|
10166 |
|
|
*/
|
10167 |
|
|
int Et_EvalTrace = 0;
|
10168 |
|
|
|
10169 |
|
|
/*
|
10170 |
|
|
** Eval the results of a string.
|
10171 |
|
|
*/
|
10172 |
|
|
int Et_EvalF(Tcl_Interp *interp, const char *zFormat, ...){
|
10173 |
|
|
char *zCmd;
|
10174 |
|
|
va_list ap;
|
10175 |
|
|
int result;
|
10176 |
|
|
va_start(ap,zFormat);
|
10177 |
|
|
zCmd = vmprintf(zFormat,ap);
|
10178 |
|
|
if( Et_EvalTrace ) printf("%s\n",zCmd);
|
10179 |
|
|
result = Tcl_Eval(interp,zCmd);
|
10180 |
|
|
if( Et_EvalTrace ) printf("%d %s\n",result,Tcl_GetStringResult(interp));
|
10181 |
|
|
Tcl_Free(zCmd);
|
10182 |
|
|
return result;
|
10183 |
|
|
}
|
10184 |
|
|
int Et_GlobalEvalF(Tcl_Interp *interp, const char *zFormat, ...){
|
10185 |
|
|
char *zCmd;
|
10186 |
|
|
va_list ap;
|
10187 |
|
|
int result;
|
10188 |
|
|
va_start(ap,zFormat);
|
10189 |
|
|
zCmd = vmprintf(zFormat,ap);
|
10190 |
|
|
if( Et_EvalTrace ) printf("%s\n",zCmd);
|
10191 |
|
|
result = Tcl_GlobalEval(interp,zCmd);
|
10192 |
|
|
if( Et_EvalTrace ) printf("%d %s\n",result,Tcl_GetStringResult(interp));
|
10193 |
|
|
Tcl_Free(zCmd);
|
10194 |
|
|
return result;
|
10195 |
|
|
}
|
10196 |
|
|
|
10197 |
|
|
/*
|
10198 |
|
|
** Set the result of an interpreter using printf-like arguments.
|
10199 |
|
|
*/
|
10200 |
|
|
void Et_ResultF(Tcl_Interp *interp, const char *zFormat, ...){
|
10201 |
|
|
Tcl_DString str;
|
10202 |
|
|
va_list ap;
|
10203 |
|
|
|
10204 |
|
|
Tcl_DStringInit(&str);
|
10205 |
|
|
va_start(ap,zFormat);
|
10206 |
|
|
vxprintf(dstringout,&str,zFormat,ap);
|
10207 |
|
|
va_end(ap);
|
10208 |
|
|
Tcl_DStringResult(interp,&str);
|
10209 |
|
|
}
|
10210 |
|
|
|
10211 |
|
|
#if ET_HAVE_OBJ
|
10212 |
|
|
/*
|
10213 |
|
|
** Append text to a string object.
|
10214 |
|
|
*/
|
10215 |
|
|
int Et_AppendObjF(Tcl_Obj *pObj, const char *zFormat, ...){
|
10216 |
|
|
va_list ap;
|
10217 |
|
|
int rc;
|
10218 |
|
|
|
10219 |
|
|
va_start(ap,zFormat);
|
10220 |
|
|
rc = vxprintf((void(*)(void*,char*,int))Tcl_AppendToObj, pObj, zFormat, ap);
|
10221 |
|
|
va_end(ap);
|
10222 |
|
|
return rc;
|
10223 |
|
|
}
|
10224 |
|
|
#endif
|
10225 |
|
|
|
10226 |
|
|
|
10227 |
|
|
#if ET_WIN32
|
10228 |
|
|
/*
|
10229 |
|
|
** This array translates all characters into themselves. Except
|
10230 |
|
|
** for the \ which gets translated into /. And all upper-case
|
10231 |
|
|
** characters are translated into lower case. This is used for
|
10232 |
|
|
** hashing and comparing filenames, to work around the Windows
|
10233 |
|
|
** bug of ignoring filename case and using the wrong separator
|
10234 |
|
|
** character for directories.
|
10235 |
|
|
**
|
10236 |
|
|
** The array is initialized by FilenameHashInit().
|
10237 |
|
|
**
|
10238 |
|
|
** We also define a macro ET_TRANS() that actually does
|
10239 |
|
|
** the character translation. ET_TRANS() is a no-op under
|
10240 |
|
|
** unix.
|
10241 |
|
|
*/
|
10242 |
|
|
static char charTrans[256];
|
10243 |
|
|
#define ET_TRANS(X) (charTrans[0xff&(int)(X)])
|
10244 |
|
|
#else
|
10245 |
|
|
#define ET_TRANS(X) (X)
|
10246 |
|
|
#endif
|
10247 |
|
|
|
10248 |
|
|
/*
|
10249 |
|
|
** Hash a filename. The value returned is appropriate for
|
10250 |
|
|
** indexing into the Et_FileHashTable[] array.
|
10251 |
|
|
*/
|
10252 |
|
|
static int FilenameHash(char *zName){
|
10253 |
|
|
int h = 0;
|
10254 |
|
|
while( *zName ){
|
10255 |
|
|
h = h ^ (h<<5) ^ ET_TRANS(*(zName++));
|
10256 |
|
|
}
|
10257 |
|
|
if( h<0 ) h = -h;
|
10258 |
|
|
return h % (sizeof(Et_FileHashTable)/sizeof(Et_FileHashTable[0]));
|
10259 |
|
|
}
|
10260 |
|
|
|
10261 |
|
|
/*
|
10262 |
|
|
** Compare two filenames. Return 0 if they are the same and
|
10263 |
|
|
** non-zero if they are different.
|
10264 |
|
|
*/
|
10265 |
|
|
static int FilenameCmp(char *z1, char *z2){
|
10266 |
|
|
int diff;
|
10267 |
|
|
while( (diff = ET_TRANS(*z1)-ET_TRANS(*z2))==0 && *z1!=0){
|
10268 |
|
|
z1++;
|
10269 |
|
|
z2++;
|
10270 |
|
|
}
|
10271 |
|
|
return diff;
|
10272 |
|
|
}
|
10273 |
|
|
|
10274 |
|
|
/*
|
10275 |
|
|
** Initialize the file hash table
|
10276 |
|
|
*/
|
10277 |
|
|
static void FilenameHashInit(void){
|
10278 |
|
|
int i;
|
10279 |
|
|
#if ET_WIN32
|
10280 |
|
|
for(i=0; i<sizeof(charTrans); i++){
|
10281 |
|
|
charTrans[i] = i;
|
10282 |
|
|
}
|
10283 |
|
|
for(i='A'; i<='Z'; i++){
|
10284 |
|
|
charTrans[i] = i + 'a' - 'A';
|
10285 |
|
|
}
|
10286 |
|
|
charTrans['\\'] = '/';
|
10287 |
|
|
#endif
|
10288 |
|
|
for(i=0; i<sizeof(Et_FileSet)/sizeof(Et_FileSet[0]) - 1; i++){
|
10289 |
|
|
struct EtFile *p;
|
10290 |
|
|
int h;
|
10291 |
|
|
p = &Et_FileSet[i];
|
10292 |
|
|
h = FilenameHash(p->zName);
|
10293 |
|
|
p->pNext = Et_FileHashTable[h];
|
10294 |
|
|
Et_FileHashTable[h] = p;
|
10295 |
|
|
}
|
10296 |
|
|
}
|
10297 |
|
|
|
10298 |
|
|
/*
|
10299 |
|
|
** Locate the text of a built-in file given its name.
|
10300 |
|
|
** Return 0 if not found. Return this size of the file (not
|
10301 |
|
|
** counting the null-terminator) in *pSize if pSize!=NULL.
|
10302 |
|
|
**
|
10303 |
|
|
** If deshroud==1 and the file is shrouded, then descramble
|
10304 |
|
|
** the text.
|
10305 |
|
|
*/
|
10306 |
|
|
static char *FindBuiltinFile(char *zName, int deshroud, int *pSize){
|
10307 |
|
|
int h;
|
10308 |
|
|
struct EtFile *p;
|
10309 |
|
|
|
10310 |
|
|
h = FilenameHash(zName);
|
10311 |
|
|
p = Et_FileHashTable[h];
|
10312 |
|
|
while( p && FilenameCmp(p->zName,zName)!=0 ){ p = p->pNext; }
|
10313 |
|
|
#if ET_SHROUD_KEY>0
|
10314 |
|
|
if( p && p->shrouded && deshroud ){
|
10315 |
|
|
char *z;
|
10316 |
|
|
int xor = ET_SHROUD_KEY;
|
10317 |
|
|
for(z=p->zData; *z; z++){
|
10318 |
|
|
if( *z>=0x20 ){ *z ^= xor; xor = (xor+1)&0x1f; }
|
10319 |
|
|
}
|
10320 |
|
|
p->shrouded = 0;
|
10321 |
|
|
}
|
10322 |
|
|
#endif
|
10323 |
|
|
if( p && pSize ){
|
10324 |
|
|
*pSize = p->nData;
|
10325 |
|
|
}
|
10326 |
|
|
return p ? p->zData : 0;
|
10327 |
|
|
}
|
10328 |
|
|
|
10329 |
|
|
/*
|
10330 |
|
|
** Add a new file to the list of built-in files.
|
10331 |
|
|
**
|
10332 |
|
|
** This routine makes a copy of zFilename. But it does NOT make
|
10333 |
|
|
** a copy of zData. It just holds a pointer to zData and uses
|
10334 |
|
|
** that for all file access. So after calling this routine,
|
10335 |
|
|
** you should never change zData!
|
10336 |
|
|
*/
|
10337 |
|
|
void Et_NewBuiltinFile(
|
10338 |
|
|
char *zFilename, /* Name of the new file */
|
10339 |
|
|
char *zData, /* Data for the new file */
|
10340 |
|
|
int nData /* Number of bytes in the new file */
|
10341 |
|
|
){
|
10342 |
|
|
int h;
|
10343 |
|
|
struct EtFile *p;
|
10344 |
|
|
|
10345 |
|
|
p = (struct EtFile*)Tcl_Alloc( sizeof(struct EtFile) + strlen(zFilename) + 1);
|
10346 |
|
|
if( p==0 ) return;
|
10347 |
|
|
p->zName = (char*)&p[1];
|
10348 |
|
|
strcpy(p->zName, zFilename);
|
10349 |
|
|
p->zData = zData;
|
10350 |
|
|
p->nData = nData;
|
10351 |
|
|
p->shrouded = 0;
|
10352 |
|
|
h = FilenameHash(zFilename);
|
10353 |
|
|
p->pNext = Et_FileHashTable[h];
|
10354 |
|
|
Et_FileHashTable[h] = p;
|
10355 |
|
|
}
|
10356 |
|
|
|
10357 |
|
|
/*
|
10358 |
|
|
** A TCL interface to the Et_NewBuiltinFile function. For Tcl8.0
|
10359 |
|
|
** and later, we make this an Obj command so that it can deal with
|
10360 |
|
|
** binary data.
|
10361 |
|
|
*/
|
10362 |
|
|
#if ET_HAVE_OBJ
|
10363 |
|
|
static int Et_NewBuiltinFileCmd(ET_OBJARGS){
|
10364 |
|
|
char *zData, *zNew;
|
10365 |
|
|
int nData;
|
10366 |
|
|
if( objc!=3 ){
|
10367 |
|
|
Tcl_WrongNumArgs(interp, 1, objv, "filename data");
|
10368 |
|
|
return TCL_ERROR;
|
10369 |
|
|
}
|
10370 |
|
|
zData = (char*)Tcl_GetByteArrayFromObj(objv[2], &nData);
|
10371 |
|
|
zNew = Tcl_Alloc( nData + 1 );
|
10372 |
|
|
if( zNew ){
|
10373 |
|
|
memcpy(zNew, zData, nData);
|
10374 |
|
|
zNew[nData] = 0;
|
10375 |
|
|
Et_NewBuiltinFile(Tcl_GetStringFromObj(objv[1], 0), zNew, nData);
|
10376 |
|
|
}
|
10377 |
|
|
return TCL_OK;
|
10378 |
|
|
}
|
10379 |
|
|
#else
|
10380 |
|
|
static int Et_NewBuiltinFileCmd(ET_TCLARGS){
|
10381 |
|
|
char *zData;
|
10382 |
|
|
int nData;
|
10383 |
|
|
if( argc!=3 ){
|
10384 |
|
|
Et_ResultF(interp,"wrong # args: should be \"%s FILENAME DATA\"", argv[0]);
|
10385 |
|
|
return TCL_ERROR;
|
10386 |
|
|
}
|
10387 |
|
|
nData = strlen(argv[2]) + 1;
|
10388 |
|
|
zData = Tcl_Alloc( nData );
|
10389 |
|
|
if( zData ){
|
10390 |
|
|
strcpy(zData, argv[2]);
|
10391 |
|
|
Et_NewBuiltinFile(argv[1], zData, nData);
|
10392 |
|
|
}
|
10393 |
|
|
return TCL_OK;
|
10394 |
|
|
}
|
10395 |
|
|
#endif
|
10396 |
|
|
|
10397 |
|
|
/*
|
10398 |
|
|
** The following section implements the InsertProc functionality. The
|
10399 |
|
|
** new InsertProc feature of Tcl8.0.3 and later allows us to overload
|
10400 |
|
|
** the usual system call commands for file I/O and replace them with
|
10401 |
|
|
** commands that operate on the built-in files.
|
10402 |
|
|
*/
|
10403 |
|
|
#ifdef ET_HAVE_INSERTPROC
|
10404 |
|
|
|
10405 |
|
|
/*
|
10406 |
|
|
** Each open channel to a built-in file is an instance of the
|
10407 |
|
|
** following structure.
|
10408 |
|
|
*/
|
10409 |
|
|
typedef struct Et_FileStruct {
|
10410 |
|
|
char *zData; /* All of the data */
|
10411 |
|
|
int nData; /* Bytes of data, not counting the null terminator */
|
10412 |
|
|
int cursor; /* How much of the data has been read so far */
|
10413 |
|
|
} Et_FileStruct;
|
10414 |
|
|
|
10415 |
|
|
/*
|
10416 |
|
|
** Close a previously opened built-in file.
|
10417 |
|
|
*/
|
10418 |
|
|
static int Et_FileClose(ClientData instanceData, Tcl_Interp *interp){
|
10419 |
|
|
Et_FileStruct *p = (Et_FileStruct*)instanceData;
|
10420 |
|
|
Tcl_Free((char*)p);
|
10421 |
|
|
return 0;
|
10422 |
|
|
}
|
10423 |
|
|
|
10424 |
|
|
/*
|
10425 |
|
|
** Read from a built-in file.
|
10426 |
|
|
*/
|
10427 |
|
|
static int Et_FileInput(
|
10428 |
|
|
ClientData instanceData, /* The file structure */
|
10429 |
|
|
char *buf, /* Write the data read here */
|
10430 |
|
|
int bufSize, /* Read this much data */
|
10431 |
|
|
int *pErrorCode /* Write the error code here */
|
10432 |
|
|
){
|
10433 |
|
|
Et_FileStruct *p = (Et_FileStruct*)instanceData;
|
10434 |
|
|
*pErrorCode = 0;
|
10435 |
|
|
if( p->cursor+bufSize>p->nData ){
|
10436 |
|
|
bufSize = p->nData - p->cursor;
|
10437 |
|
|
}
|
10438 |
|
|
memcpy(buf, &p->zData[p->cursor], bufSize);
|
10439 |
|
|
p->cursor += bufSize;
|
10440 |
|
|
return bufSize;
|
10441 |
|
|
}
|
10442 |
|
|
|
10443 |
|
|
/*
|
10444 |
|
|
** Writes to a built-in file always return EOF.
|
10445 |
|
|
*/
|
10446 |
|
|
static int Et_FileOutput(
|
10447 |
|
|
ClientData instanceData, /* The file structure */
|
10448 |
|
|
char *buf, /* Read the data from here */
|
10449 |
|
|
int toWrite, /* Write this much data */
|
10450 |
|
|
int *pErrorCode /* Write the error code here */
|
10451 |
|
|
){
|
10452 |
|
|
*pErrorCode = 0;
|
10453 |
|
|
return 0;
|
10454 |
|
|
}
|
10455 |
|
|
|
10456 |
|
|
/*
|
10457 |
|
|
** Move the cursor around within the built-in file.
|
10458 |
|
|
*/
|
10459 |
|
|
static int Et_FileSeek(
|
10460 |
|
|
ClientData instanceData, /* The file structure */
|
10461 |
|
|
long offset, /* Offset to seek to */
|
10462 |
|
|
int mode, /* One of SEEK_CUR, SEEK_SET or SEEK_END */
|
10463 |
|
|
int *pErrorCode /* Write the error code here */
|
10464 |
|
|
){
|
10465 |
|
|
Et_FileStruct *p = (Et_FileStruct*)instanceData;
|
10466 |
|
|
switch( mode ){
|
10467 |
|
|
case SEEK_CUR: offset += p->cursor; break;
|
10468 |
|
|
case SEEK_END: offset += p->nData; break;
|
10469 |
|
|
default: break;
|
10470 |
|
|
}
|
10471 |
|
|
if( offset<0 ) offset = 0;
|
10472 |
|
|
if( offset>p->nData ) offset = p->nData;
|
10473 |
|
|
p->cursor = offset;
|
10474 |
|
|
return offset;
|
10475 |
|
|
}
|
10476 |
|
|
|
10477 |
|
|
/*
|
10478 |
|
|
** The Watch method is a no-op
|
10479 |
|
|
*/
|
10480 |
|
|
static void Et_FileWatch(ClientData instanceData, int mask){
|
10481 |
|
|
}
|
10482 |
|
|
|
10483 |
|
|
/*
|
10484 |
|
|
** The Handle method always returns an error.
|
10485 |
|
|
*/
|
10486 |
|
|
static int Et_FileHandle(ClientData notUsed, int dir, ClientData *handlePtr){
|
10487 |
|
|
return TCL_ERROR;
|
10488 |
|
|
}
|
10489 |
|
|
|
10490 |
|
|
/*
|
10491 |
|
|
** This is the channel type that will access the built-in files.
|
10492 |
|
|
*/
|
10493 |
|
|
static Tcl_ChannelType builtinChannelType = {
|
10494 |
|
|
"builtin", /* Type name. */
|
10495 |
|
|
NULL, /* Always non-blocking.*/
|
10496 |
|
|
Et_FileClose, /* Close proc. */
|
10497 |
|
|
Et_FileInput, /* Input proc. */
|
10498 |
|
|
Et_FileOutput, /* Output proc. */
|
10499 |
|
|
Et_FileSeek, /* Seek proc. */
|
10500 |
|
|
NULL, /* Set option proc. */
|
10501 |
|
|
NULL, /* Get option proc. */
|
10502 |
|
|
Et_FileWatch, /* Watch for events on console. */
|
10503 |
|
|
Et_FileHandle, /* Get a handle from the device. */
|
10504 |
|
|
};
|
10505 |
|
|
|
10506 |
|
|
/*
|
10507 |
|
|
** This routine attempts to do an open of a built-in file.
|
10508 |
|
|
*/
|
10509 |
|
|
static Tcl_Channel Et_FileOpen(
|
10510 |
|
|
Tcl_Interp *interp, /* The TCL interpreter doing the open */
|
10511 |
|
|
char *zFilename, /* Name of the file to open */
|
10512 |
|
|
char *modeString, /* Mode string for the open (ignored) */
|
10513 |
|
|
int permissions /* Permissions for a newly created file (ignored) */
|
10514 |
|
|
){
|
10515 |
|
|
char *zData;
|
10516 |
|
|
Et_FileStruct *p;
|
10517 |
|
|
int nData;
|
10518 |
|
|
char zName[50];
|
10519 |
|
|
Tcl_Channel chan;
|
10520 |
|
|
static int count = 1;
|
10521 |
|
|
|
10522 |
|
|
zData = FindBuiltinFile(zFilename, 1, &nData);
|
10523 |
|
|
if( zData==0 ) return NULL;
|
10524 |
|
|
p = (Et_FileStruct*)Tcl_Alloc( sizeof(Et_FileStruct) );
|
10525 |
|
|
if( p==0 ) return NULL;
|
10526 |
|
|
p->zData = zData;
|
10527 |
|
|
p->nData = nData;
|
10528 |
|
|
p->cursor = 0;
|
10529 |
|
|
sprintf(zName,"etbi_%x_%x",((int)Et_FileOpen)>>12,count++);
|
10530 |
|
|
chan = Tcl_CreateChannel(&builtinChannelType, zName,
|
10531 |
|
|
(ClientData)p, TCL_READABLE);
|
10532 |
|
|
return chan;
|
10533 |
|
|
}
|
10534 |
|
|
|
10535 |
|
|
/*
|
10536 |
|
|
** This routine does a stat() system call for a built-in file.
|
10537 |
|
|
*/
|
10538 |
|
|
static int Et_FileStat(char *path, struct stat *buf){
|
10539 |
|
|
char *zData;
|
10540 |
|
|
int nData;
|
10541 |
|
|
|
10542 |
|
|
zData = FindBuiltinFile(path, 0, &nData);
|
10543 |
|
|
if( zData==0 ){
|
10544 |
|
|
return -1;
|
10545 |
|
|
}
|
10546 |
|
|
memset(buf, 0, sizeof(*buf));
|
10547 |
|
|
buf->st_mode = 0400;
|
10548 |
|
|
buf->st_size = nData;
|
10549 |
|
|
return 0;
|
10550 |
|
|
}
|
10551 |
|
|
|
10552 |
|
|
/*
|
10553 |
|
|
** This routien does an access() system call for a built-in file.
|
10554 |
|
|
*/
|
10555 |
|
|
static int Et_FileAccess(char *path, int mode){
|
10556 |
|
|
char *zData;
|
10557 |
|
|
|
10558 |
|
|
if( mode & 3 ){
|
10559 |
|
|
return -1;
|
10560 |
|
|
}
|
10561 |
|
|
zData = FindBuiltinFile(path, 0, 0);
|
10562 |
|
|
if( zData==0 ){
|
10563 |
|
|
return -1;
|
10564 |
|
|
}
|
10565 |
|
|
return 0;
|
10566 |
|
|
}
|
10567 |
|
|
#endif /* ET_HAVE_INSERTPROC */
|
10568 |
|
|
|
10569 |
|
|
/*
|
10570 |
|
|
** An overloaded version of "source". First check for the file
|
10571 |
|
|
** is one of the built-ins. If it isn't a built-in, then check the
|
10572 |
|
|
** disk. But if ET_STANDALONE is set (which corresponds to the
|
10573 |
|
|
** "Strict" option in the user interface) then never check the disk.
|
10574 |
|
|
** This gives us a quick way to check for the common error of
|
10575 |
|
|
** sourcing a file that exists on the development by mistake,
|
10576 |
|
|
** and only discovering the mistake when you move the program
|
10577 |
|
|
** to your customer's machine.
|
10578 |
|
|
*/
|
10579 |
|
|
static int Et_Source(ET_TCLARGS){
|
10580 |
|
|
char *z;
|
10581 |
|
|
|
10582 |
|
|
if( argc!=2 ){
|
10583 |
|
|
Et_ResultF(interp,"wrong # args: should be \"%s FILENAME\"", argv[0]);
|
10584 |
|
|
return TCL_ERROR;
|
10585 |
|
|
}
|
10586 |
|
|
z = FindBuiltinFile(argv[1], 1, 0);
|
10587 |
|
|
if( z ){
|
10588 |
|
|
int rc;
|
10589 |
|
|
rc = Tcl_Eval(interp,z);
|
10590 |
|
|
if (rc == TCL_ERROR) {
|
10591 |
|
|
char msg[200];
|
10592 |
|
|
sprintf(msg, "\n (file \"%.150s\" line %d)", argv[1],
|
10593 |
|
|
interp->errorLine);
|
10594 |
|
|
Tcl_AddErrorInfo(interp, msg);
|
10595 |
|
|
} else {
|
10596 |
|
|
rc = TCL_OK;
|
10597 |
|
|
}
|
10598 |
|
|
return rc;
|
10599 |
|
|
}
|
10600 |
|
|
#if ET_STANDALONE
|
10601 |
|
|
Et_ResultF(interp,"no such file: \"%s\"", argv[1]);
|
10602 |
|
|
return TCL_ERROR;
|
10603 |
|
|
#else
|
10604 |
|
|
return Tcl_EvalFile(interp,argv[1]);
|
10605 |
|
|
#endif
|
10606 |
|
|
}
|
10607 |
|
|
|
10608 |
|
|
#ifndef ET_HAVE_INSERTPROC
|
10609 |
|
|
/*
|
10610 |
|
|
** An overloaded version of "file exists". First check for the file
|
10611 |
|
|
** in the file table, then go to disk.
|
10612 |
|
|
**
|
10613 |
|
|
** We only overload "file exists" if we don't have InsertProc()
|
10614 |
|
|
** procedures. If we do have InsertProc() procedures, they will
|
10615 |
|
|
** handle this more efficiently.
|
10616 |
|
|
*/
|
10617 |
|
|
static int Et_FileExists(ET_TCLARGS){
|
10618 |
|
|
int i, rc;
|
10619 |
|
|
Tcl_DString str;
|
10620 |
|
|
if( argc==3 && strncmp(argv[1],"exis",4)==0 ){
|
10621 |
|
|
if( FindBuiltinFile(argv[2], 0, 0)!=0 ){
|
10622 |
|
|
Tcl_SetResult(interp, "1", TCL_STATIC);
|
10623 |
|
|
return TCL_OK;
|
10624 |
|
|
}
|
10625 |
|
|
}
|
10626 |
|
|
Tcl_DStringInit(&str);
|
10627 |
|
|
Tcl_DStringAppendElement(&str,"Et_FileCmd");
|
10628 |
|
|
for(i=1; i<argc; i++){
|
10629 |
|
|
Tcl_DStringAppendElement(&str, argv[i]);
|
10630 |
|
|
}
|
10631 |
|
|
rc = Tcl_Eval(interp, Tcl_DStringValue(&str));
|
10632 |
|
|
Tcl_DStringFree(&str);
|
10633 |
|
|
return rc;
|
10634 |
|
|
}
|
10635 |
|
|
#endif
|
10636 |
|
|
|
10637 |
|
|
/*
|
10638 |
|
|
** This is the main Tcl interpreter. It's a global variable so it
|
10639 |
|
|
** can be accessed easily from C code.
|
10640 |
|
|
*/
|
10641 |
|
|
Tcl_Interp *Et_Interp = 0;
|
10642 |
|
|
|
10643 |
|
|
|
10644 |
|
|
#if ET_WIN32
|
10645 |
|
|
/*
|
10646 |
|
|
** Implement the Et_MessageBox command on Windows platforms. We
|
10647 |
|
|
** use the MessageBox() function from the Win32 API so that the
|
10648 |
|
|
** error message will be displayed as a dialog box. Writing to
|
10649 |
|
|
** standard error doesn't do anything on windows.
|
10650 |
|
|
*/
|
10651 |
|
|
int Et_MessageBox(ET_TCLARGS){
|
10652 |
|
|
char *zMsg = "(Empty Message)";
|
10653 |
|
|
char *zTitle = "Message...";
|
10654 |
|
|
|
10655 |
|
|
if( argc>1 ){
|
10656 |
|
|
zTitle = argv[1];
|
10657 |
|
|
}
|
10658 |
|
|
if( argc>2 ){
|
10659 |
|
|
zMsg = argv[2];
|
10660 |
|
|
}
|
10661 |
|
|
MessageBox(0, zMsg, zTitle, MB_ICONSTOP | MB_OK);
|
10662 |
|
|
return TCL_OK;
|
10663 |
|
|
}
|
10664 |
|
|
#endif
|
10665 |
|
|
|
10666 |
|
|
/*
|
10667 |
|
|
** A default implementation for "bgerror"
|
10668 |
|
|
*/
|
10669 |
|
|
static char zBgerror[] =
|
10670 |
|
|
"proc Et_Bgerror err {\n"
|
10671 |
|
|
" global errorInfo tk_library\n"
|
10672 |
|
|
" if {[info exists errorInfo]} {\n"
|
10673 |
|
|
" set ei $errorInfo\n"
|
10674 |
|
|
" } else {\n"
|
10675 |
|
|
" set ei {}\n"
|
10676 |
|
|
" }\n"
|
10677 |
|
|
" if {[catch {bgerror $err}]==0} return\n"
|
10678 |
|
|
" if {[string length $ei]>0} {\n"
|
10679 |
|
|
" set err $ei\n"
|
10680 |
|
|
" }\n"
|
10681 |
|
|
" if {[catch {Et_MessageBox {Error} $err}]} {\n"
|
10682 |
|
|
" puts stderr $err\n"
|
10683 |
|
|
" }\n"
|
10684 |
|
|
" exit\n"
|
10685 |
|
|
"}\n"
|
10686 |
|
|
;
|
10687 |
|
|
|
10688 |
|
|
/*
|
10689 |
|
|
** Do the initialization.
|
10690 |
|
|
**
|
10691 |
|
|
** This routine is called after the interpreter is created, but
|
10692 |
|
|
** before Et_PreInit() or Et_AppInit() have been run.
|
10693 |
|
|
*/
|
10694 |
|
|
int Et_DoInit(Tcl_Interp *interp){
|
10695 |
|
|
extern int Et_PreInit(Tcl_Interp*);
|
10696 |
|
|
extern int Et_AppInit(Tcl_Interp*);
|
10697 |
|
|
|
10698 |
|
|
|
10699 |
|
|
/* Insert our alternative stat(), access() and open() procedures
|
10700 |
|
|
** so that any attempt to work with a file will check our built-in
|
10701 |
|
|
** scripts first.
|
10702 |
|
|
*/
|
10703 |
|
|
TclStatInsertProc(Et_FileStat);
|
10704 |
|
|
TclAccessInsertProc(Et_FileAccess);
|
10705 |
|
|
TclOpenFileChannelInsertProc(Et_FileOpen);
|
10706 |
|
|
|
10707 |
|
|
/* Initialize the hash-table for built-in scripts
|
10708 |
|
|
*/
|
10709 |
|
|
FilenameHashInit();
|
10710 |
|
|
|
10711 |
|
|
|
10712 |
|
|
/* Overload the "file" and "source" commands
|
10713 |
|
|
*/
|
10714 |
|
|
Tcl_CreateCommand(interp,"source",Et_Source,0,0);
|
10715 |
|
|
|
10716 |
|
|
|
10717 |
|
|
/* Define the variable Et_Interp to hold the interpreter.
|
10718 |
|
|
** Not sure if this is ever used.
|
10719 |
|
|
*/
|
10720 |
|
|
Et_Interp = interp;
|
10721 |
|
|
|
10722 |
|
|
/* Not sure if these variables are used. Need to
|
10723 |
|
|
** research.
|
10724 |
|
|
*/
|
10725 |
|
|
Tcl_SetVar(interp,"tcl_library",ET_TCL_LIBRARY,TCL_GLOBAL_ONLY);
|
10726 |
|
|
Tcl_SetVar(interp,"tcl_libPath",ET_TCL_LIBRARY,TCL_GLOBAL_ONLY);
|
10727 |
|
|
Tcl_SetVar2(interp,"env","TCL_LIBRARY",ET_TCL_LIBRARY,TCL_GLOBAL_ONLY);
|
10728 |
|
|
|
10729 |
|
|
|
10730 |
|
|
/* Not sure if these variables are used. Need to research.
|
10731 |
|
|
*/
|
10732 |
|
|
Tcl_SetVar(interp,"tk_library",ET_TK_LIBRARY,TCL_GLOBAL_ONLY);
|
10733 |
|
|
Tcl_SetVar2(interp,"env","TK_LIBRARY",ET_TK_LIBRARY,TCL_GLOBAL_ONLY);
|
10734 |
|
|
|
10735 |
|
|
/* Not sure of the purpose of this line. Need to research.
|
10736 |
|
|
*/
|
10737 |
|
|
Tcl_Eval(interp,zBgerror);
|
10738 |
|
|
|
10739 |
|
|
|
10740 |
|
|
/* Not sure of the purpose of this line. Need to research.
|
10741 |
|
|
*/
|
10742 |
|
|
Et_GlobalEvalF(interp,"set dir $tcl_library;source $dir/tclIndex;unset dir");
|
10743 |
|
|
|
10744 |
|
|
/* Unsure of function of following lines. Need to research.
|
10745 |
|
|
*/
|
10746 |
|
|
Tcl_LinkVar(interp,"Et_EvalTrace",(char*)&Et_EvalTrace,TCL_LINK_BOOLEAN);
|
10747 |
|
|
Tcl_SetVar(interp,"et_version",ET_VERSION,TCL_GLOBAL_ONLY);
|
10748 |
|
|
|
10749 |
|
|
return TCL_OK;
|
10750 |
|
|
|
10751 |
|
|
/* Put in a dummy goto, just to keep the compiler happy. Might want to keep
|
10752 |
|
|
** the code below, just in case.
|
10753 |
|
|
*/
|
10754 |
|
|
goto initerr;
|
10755 |
|
|
|
10756 |
|
|
initerr:
|
10757 |
|
|
Et_EvalF(interp,"Et_Bgerror \"%q\"", Tcl_GetStringResult(interp));
|
10758 |
|
|
return TCL_ERROR;
|
10759 |
|
|
}
|
10760 |
|
|
|
10761 |
|
|
|
10762 |
|
|
#if ET_EXTENSION
|
10763 |
|
|
/*
|
10764 |
|
|
** If the -extension flag is used, then generate code that will be
|
10765 |
|
|
** turned into a loadable shared library or DLL, not a standalone
|
10766 |
|
|
** executable.
|
10767 |
|
|
*/
|
10768 |
|
|
int ET_EXTENSION_NAME(Tcl_Interp *interp){
|
10769 |
|
|
int i;
|
10770 |
|
|
#ifndef ET_HAVE_INSERTPROC
|
10771 |
|
|
Tcl_AppendResult(interp,
|
10772 |
|
|
"mktclapp can only generate extensions for Tcl/Tk version "
|
10773 |
|
|
"8.0.3 and later. This is version "
|
10774 |
|
|
TCL_MAJOR_VERSION "." TCL_MINOR_VERSION "." TCL_RELEASE_SERIAL, 0);
|
10775 |
|
|
return TCL_ERROR;
|
10776 |
|
|
#endif
|
10777 |
|
|
#ifdef ET_HAVE_INSERTPROC
|
10778 |
|
|
#ifdef USE_TCL_STUBS
|
10779 |
|
|
if( Tcl_InitStubs(interp,"8.0",0)==0 ){
|
10780 |
|
|
return TCL_ERROR;
|
10781 |
|
|
}
|
10782 |
|
|
if( Tk_InitStubs(interp,"8.0",0)==0 ){
|
10783 |
|
|
return TCL_ERROR;
|
10784 |
|
|
}
|
10785 |
|
|
#endif
|
10786 |
|
|
Et_Interp = interp;
|
10787 |
|
|
TclStatInsertProc(Et_FileStat);
|
10788 |
|
|
TclAccessInsertProc(Et_FileAccess);
|
10789 |
|
|
TclOpenFileChannelInsertProc(Et_FileOpen);
|
10790 |
|
|
FilenameHashInit();
|
10791 |
|
|
for(i=0; i<sizeof(Et_CmdSet)/sizeof(Et_CmdSet[0]) - 1; i++){
|
10792 |
|
|
Tcl_CreateCommand(interp, Et_CmdSet[i].zName, Et_CmdSet[i].xProc, 0, 0);
|
10793 |
|
|
}
|
10794 |
|
|
#if ET_ENABLE_OBJ
|
10795 |
|
|
for(i=0; i<sizeof(Et_ObjSet)/sizeof(Et_ObjSet[0]) - 1; i++){
|
10796 |
|
|
Tcl_CreateObjCommand(interp, Et_ObjSet[i].zName, Et_ObjSet[i].xProc, 0, 0);
|
10797 |
|
|
}
|
10798 |
|
|
#endif
|
10799 |
|
|
Tcl_LinkVar(interp,"Et_EvalTrace",(char*)&Et_EvalTrace,TCL_LINK_BOOLEAN);
|
10800 |
|
|
Tcl_SetVar(interp,"et_version",ET_VERSION,TCL_GLOBAL_ONLY);
|
10801 |
|
|
#if ET_HAVE_APPINIT
|
10802 |
|
|
if( Et_AppInit(interp) == TCL_ERROR ){
|
10803 |
|
|
return TCL_ERROR;
|
10804 |
|
|
}
|
10805 |
|
|
#endif
|
10806 |
|
|
#ifdef ET_MAIN_SCRIPT
|
10807 |
|
|
if( Et_EvalF(interp,"source \"%q\"", ET_MAIN_SCRIPT)!=TCL_OK ){
|
10808 |
|
|
return TCL_ERROR;
|
10809 |
|
|
}
|
10810 |
|
|
#endif
|
10811 |
|
|
return TCL_OK;
|
10812 |
|
|
#endif /* ET_HAVE_INSERTPROC */
|
10813 |
|
|
}
|
10814 |
|
|
int ET_SAFE_EXTENSION_NAME(Tcl_Interp *interp){
|
10815 |
|
|
return ET_EXTENSION_NAME(interp);
|
10816 |
|
|
}
|
10817 |
|
|
#endif
|
10818 |
|
|
|
10819 |
|
|
|
10820 |
|
|
/*
|
10821 |
|
|
* $Log: appinit.c,v $
|
10822 |
|
|
* Revision 1.6 2002/04/23 06:26:42 dtashley
|
10823 |
|
|
* Minor changes in release year, name (to ESRG).
|
10824 |
|
|
*
|
10825 |
|
|
* Revision 1.5 2001/08/18 18:33:13 dtashley
|
10826 |
|
|
* Preparing for release of v1.05.
|
10827 |
|
|
*
|
10828 |
|
|
* Revision 1.4 2001/06/20 20:42:28 dtashley
|
10829 |
|
|
* Final changes before release of v1.04.
|
10830 |
|
|
*
|
10831 |
|
|
* Revision 1.3 2001/06/20 03:32:56 dtashley
|
10832 |
|
|
* Modifications for version 1.04.
|
10833 |
|
|
*
|
10834 |
|
|
* Revision 1.2 2001/06/20 02:56:04 dtashley
|
10835 |
|
|
* Conversion from binary mode to work under CVS.
|
10836 |
|
|
*
|
10837 |
|
|
* $History: appinit.c $
|
10838 |
|
|
*
|
10839 |
|
|
* ***************** Version 2 *****************
|
10840 |
|
|
* User: Dtashley Date: 1/03/01 Time: 2:03a
|
10841 |
|
|
* Updated in $/IjuScripter, IjuConsole/Source/Tk Base
|
10842 |
|
|
* Check-in in preparation for release of v1.03. Extraneous and redundant
|
10843 |
|
|
* calls removed.
|
10844 |
|
|
*
|
10845 |
|
|
* ***************** Version 1 *****************
|
10846 |
|
|
* User: Dtashley Date: 1/02/01 Time: 2:18a
|
10847 |
|
|
* Created in $/IjuScripter, IjuConsole/Source/Tk Base
|
10848 |
|
|
* Initial check-in.
|
10849 |
|
|
*/
|
10850 |
|
|
|
10851 |
|
|
/* End of APPINIT.C */ |