Mercurial > hg > Applications > Lite

comparison xf-disp @ 2:1c57a78f1d98

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Initial revision
author kono
date Thu, 18 Jan 2001 23:27:24 +0900
parents
children
comparison
equal deleted inserted replaced
1:683efd6f9a81 2:1c57a78f1d98
1 #!/usr/local/bin/wish -f
2 # Program: xf-disp
3 # Tcl version: 7.3 (Tcl/Tk/XF)
4 # Tk version: 3.6
5 # XF version: 2.2
6 #
7
8 # module inclusion
9 global env
10 global xfLoadPath
11 global xfLoadInfo
12 set xfLoadInfo 0
13 if {[info exists env(XF_LOAD_PATH)]} {
14 if {[string first $env(XF_LOAD_PATH) /usr/local/lib/] == -1} {
15 set xfLoadPath $env(XF_LOAD_PATH):/usr/local/lib/
16 } {
17 set xfLoadPath /usr/local/lib/
18 }
19 } {
20 set xfLoadPath /usr/local/lib/
21 }
22
23 global argc
24 global argv
25 global tkVersion
26 set tmpArgv ""
27 for {set counter 0} {$counter < $argc} {incr counter 1} {
28 case [string tolower [lindex $argv $counter]] in {
29 {-xfloadpath} {
30 incr counter 1
31 set xfLoadPath "[lindex $argv $counter]:$xfLoadPath"
32 }
33 {-xfstartup} {
34 incr counter 1
35 source [lindex $argv $counter]
36 }
37 {-xfbindfile} {
38 incr counter 1
39 set env(XF_BIND_FILE) "[lindex $argv $counter]"
40 }
41 {-xfcolorfile} {
42 incr counter 1
43 set env(XF_COLOR_FILE) "[lindex $argv $counter]"
44 }
45 {-xfcursorfile} {
46 incr counter 1
47 set env(XF_CURSOR_FILE) "[lindex $argv $counter]"
48 }
49 {-xffontfile} {
50 incr counter 1
51 set env(XF_FONT_FILE) "[lindex $argv $counter]"
52 }
53 {-xfmodelmono} {
54 if {$tkVersion >= 3.0} {
55 tk colormodel . monochrome
56 }
57 }
58 {-xfmodelcolor} {
59 if {$tkVersion >= 3.0} {
60 tk colormodel . color
61 }
62 }
63 {-xfloading} {
64 set xfLoadInfo 1
65 }
66 {-xfnoloading} {
67 set xfLoadInfo 0
68 }
69 {default} {
70 lappend tmpArgv [lindex $argv $counter]
71 }
72 }
73 }
74 set argv $tmpArgv
75 set argc [llength $tmpArgv]
76 unset counter
77 unset tmpArgv
78
79
80 # procedure to show window .top0
81 proc ShowWindow.top0 {args} {# xf ignore me 7
82
83 # build widget .top0
84 if {"[info procs XFEdit]" != ""} {
85 catch "XFDestroy .top0"
86 } {
87 catch "destroy .top0"
88 }
89 toplevel .top0 \
90 -background {Cornsilk2}
91
92 # Window manager configurations
93 global tkVersion
94 wm positionfrom .top0 ""
95 wm sizefrom .top0 ""
96 wm maxsize .top0 1000 1000
97 wm minsize .top0 10 10
98 wm title .top0 {Execution}
99
100
101 # build widget .top0.frame0
102 frame .top0.frame0 \
103 -background {Cornsilk2} \
104 -relief {raised}
105
106 # build widget .top0.frame0.scrollbar3
107 scrollbar .top0.frame0.scrollbar3 \
108 -activeforeground {CornSilk2} \
109 -background {Cornsilk2} \
110 -command {.top0.frame0.canvas2 xview} \
111 -foreground {#ffe4c4} \
112 -orient {horizontal} \
113 -relief {raised}
114
115 # build widget .top0.frame0.scrollbar1
116 scrollbar .top0.frame0.scrollbar1 \
117 -activeforeground {CornSilk2} \
118 -background {Cornsilk2} \
119 -command {.top0.frame0.canvas2 yview} \
120 -foreground {#ffe4c4} \
121 -relief {raised}
122
123 # build widget .top0.frame0.canvas2
124 canvas .top0.frame0.canvas2 \
125 -background {Cornsilk2} \
126 -confine {0} \
127 -height {384} \
128 -insertofftime {600} \
129 -relief {raised} \
130 -scrollregion {-1c -1c 20c 20c} \
131 -selectbackground {#b2dfee} \
132 -selectborderwidth {1} \
133 -selectforeground {CornSilk2} \
134 -width {394} \
135 -xscrollcommand {.top0.frame0.scrollbar3 set} \
136 -yscrollcommand {.top0.frame0.scrollbar1 set}
137 # bindings
138 bind .top0.frame0.canvas2 <Button-1> {crosshair .top0.frame0.canvas2 %x %y}
139
140 # pack widget .top0.frame0
141 pack append .top0.frame0 \
142 .top0.frame0.scrollbar1 {right frame center filly} \
143 .top0.frame0.canvas2 {top frame center expand fill} \
144 .top0.frame0.scrollbar3 {top frame center fillx}
145
146 # build widget .top0.frame1
147 frame .top0.frame1 \
148 -background {Cornsilk2} \
149 -borderwidth {2} \
150 -relief {raised}
151
152 # build widget .top0.frame1.label6
153 label .top0.frame1.label6 \
154 -anchor {w} \
155 -background {Cornsilk2} \
156 -font {8x16} \
157 -kanjifont {kanji16} \
158 -relief {raised} \
159 -text {States:}
160
161 # build widget .top0.frame1.button13
162 button .top0.frame1.button13 \
163 -activebackground {#eed5b7} \
164 -activeforeground {CornSilk2} \
165 -background {Cornsilk2} \
166 -command {# regexp {([0-9]+)x([0-9]+)} [wm geometry .] dm width height
167 # set height [expr $height-300]
168 # lite map $height
169 lite map 300
170 } \
171 -disabledforeground {#b0b0b0} \
172 -font {8x16} \
173 -kanjifont {kanji16} \
174 -text {Map}
175
176 # build widget .top0.frame1.button0
177 button .top0.frame1.button0 \
178 -activeforeground {CornSilk2} \
179 -background {Cornsilk2} \
180 -command {lite generate a} \
181 -font {8x16} \
182 -kanjifont {*-fixed-*-normal--16-*-jisx0208.1983-*} \
183 -text {Generate}
184
185 # pack widget .top0.frame1
186 pack append .top0.frame1 \
187 .top0.frame1.label6 {left frame center expand fillx} \
188 .top0.frame1.button13 {left frame center} \
189 .top0.frame1.button0 {left frame center fillx}
190
191 # build widget .top0.frame6
192 frame .top0.frame6 \
193 -background {Cornsilk2} \
194 -borderwidth {2} \
195 -relief {raised}
196
197 # build widget .top0.frame6.button8
198 button .top0.frame6.button8 \
199 -activebackground {#eed5b7} \
200 -activeforeground {CornSilk2} \
201 -background {Cornsilk2} \
202 -command {lite counter a} \
203 -disabledforeground {#b0b0b0} \
204 -font {8x16} \
205 -kanjifont {kanji16} \
206 -text {Counter Example}
207
208 # build widget .top0.frame6.button10
209 button .top0.frame6.button10 \
210 -activebackground {#eed5b7} \
211 -activeforeground {CornSilk2} \
212 -background {Cornsilk2} \
213 -command {lite execute a} \
214 -disabledforeground {#b0b0b0} \
215 -font {8x16} \
216 -kanjifont {kanji16} \
217 -text {Execute}
218
219 # build widget .top0.frame6.button9
220 button .top0.frame6.button9 \
221 -activebackground {#eed5b7} \
222 -activeforeground {CornSilk2} \
223 -background {Cornsilk2} \
224 -command {canvaswh .top0.frame0.canvas2 1.6} \
225 -disabledforeground {#b0b0b0} \
226 -font {8x16} \
227 -kanjifont {kanji16} \
228 -text {Enlarge}
229
230 # build widget .top0.frame6.button11
231 button .top0.frame6.button11 \
232 -activebackground {#eed5b7} \
233 -activeforeground {CornSilk2} \
234 -background {Cornsilk2} \
235 -command {canvaswh .top0.frame0.canvas2 0.625} \
236 -disabledforeground {#b0b0b0} \
237 -font {8x16} \
238 -kanjifont {kanji16} \
239 -text { Shrink}
240
241 # pack widget .top0.frame6
242 pack append .top0.frame6 \
243 .top0.frame6.button8 {right frame center fillx} \
244 .top0.frame6.button10 {right frame center expand fillx} \
245 .top0.frame6.button9 {left frame center} \
246 .top0.frame6.button11 {left frame center}
247
248 # pack widget .top0
249 pack append .top0 \
250 .top0.frame0 {bottom frame center expand fill} \
251 .top0.frame1 {bottom frame center fill} \
252 .top0.frame6 {top frame center fillx}
253
254 # build canvas items .top0.frame0.canvas2
255 set xfTmpTag [.top0.frame0.canvas2 create window -2480.03 -2615.93]
256 .top0.frame0.canvas2 itemconfigure $xfTmpTag \
257 -anchor {nw}
258 set xfTmpTag [.top0.frame0.canvas2 create line 326 189 326 199]
259 .top0.frame0.canvas2 itemconfigure $xfTmpTag \
260 -tags {cursol}
261 set xfTmpTag [.top0.frame0.canvas2 create line 321 194 331 194]
262 .top0.frame0.canvas2 itemconfigure $xfTmpTag \
263 -tags {cursol}
264
265
266
267 if {"[info procs XFEdit]" != ""} {
268 catch "XFMiscBindWidgetTree .top0"
269 after 2 "catch {XFEditSetShowWindows}"
270 }
271 }
272
273 proc DestroyWindow.top0 {} {# xf ignore me 7
274 if {"[info procs XFEdit]" != ""} {
275 if {"[info commands .top0]" != ""} {
276 global xfShowWindow.top0
277 set xfShowWindow.top0 0
278 XFEditSetPath .
279 after 2 "XFSaveAsProc .top0; XFEditSetShowWindows"
280 }
281 } {
282 catch "destroy .top0"
283 update
284 }
285 }
286
287
288 # procedure to show window .
289 proc ShowWindow. {args} {# xf ignore me 7
290
291 # Window manager configurations
292 global tkVersion
293 wm positionfrom . user
294 wm sizefrom . user
295 wm maxsize . 1280 1024
296 wm title . {Lite}
297
298
299 # build widget .frame
300 frame .frame \
301 -background {Cornsilk2} \
302 -relief {raised}
303
304 # build widget .frame.frame0
305 frame .frame.frame0 \
306 -background {Cornsilk2} \
307 -borderwidth {2} \
308 -relief {raised}
309
310 # build widget .frame.frame0.label4
311 label .frame.frame0.label4 \
312 -background {Cornsilk2} \
313 -font {8x16} \
314 -kanjifont {kanji16} \
315 -padx {2} \
316 -relief {raised} \
317 -text {ITL Formula:}
318
319 # build widget .frame.frame0.button3
320 button .frame.frame0.button3 \
321 -activebackground {#eed5b7} \
322 -activeforeground {CornSilk2} \
323 -background {Cornsilk2} \
324 -command {text_clear .frame.frame4.text0} \
325 -disabledforeground {#b0b0b0} \
326 -font {8x16} \
327 -kanjifont {*-fixed-*-normal--16-*-jisx0208.1983-*} \
328 -text {clear}
329
330 # build widget .frame.frame0.menubutton0
331 menubutton .frame.frame0.menubutton0 \
332 -activeforeground {CornSilk2} \
333 -background {Cornsilk2} \
334 -font {8x16} \
335 -kanjifont {*-fixed-*-normal--16-*-jisx0208.1983-*} \
336 -menu {.frame.frame0.menubutton0.m} \
337 -text {file}
338 # bindings
339 bind .frame.frame0.menubutton0 <Button-1> {MenuPopupPost .frame.frame0.menubutton0.m %X %Y}
340 bind .frame.frame0.menubutton0 <ButtonRelease-1> {MenuPopupRelease .frame.frame0.menubutton0.m %W}
341
342 # build widget .frame.frame0.menubutton0.m
343 menu .frame.frame0.menubutton0.m \
344 -activeforeground {CornSilk2} \
345 -background {Cornsilk2} \
346 -font {8x16} \
347 -kanjifont {*-fixed-*-normal--16-*-jisx0208.1983-*}
348 .frame.frame0.menubutton0.m add command \
349 -command {filehandling .frame.frame4.text0 load [FSBox "load"]} \
350 -label {load}
351 .frame.frame0.menubutton0.m add command \
352 -command {filehandling .frame.frame4.text0 save [FSBox "save"]} \
353 -label {save}
354 .frame.frame0.menubutton0.m add command \
355 -command {TokioCommand} \
356 -label {Tokio}
357 .frame.frame0.menubutton0.m add command \
358 -command {PrologCommand} \
359 -label {Prolog}
360 # bindings
361 bind .frame.frame0.menubutton0.m <Any-ButtonRelease-1> {MenuPopupRelease .frame.frame0.menubutton0.m %W}
362 bind .frame.frame0.menubutton0.m <Shift-Button-1> {MenuPopupPost .frame.frame0.menubutton0.m %X %Y}
363
364 # pack widget .frame.frame0
365 pack append .frame.frame0 \
366 .frame.frame0.label4 {left frame center expand fillx} \
367 .frame.frame0.button3 {right frame center} \
368 .frame.frame0.menubutton0 {left frame center fillx}
369
370 # build widget .frame.frame4
371 frame .frame.frame4 \
372 -background {Cornsilk2} \
373 -borderwidth {2} \
374 -relief {raised}
375
376 # build widget .frame.frame4.scrollbar1
377 scrollbar .frame.frame4.scrollbar1 \
378 -activeforeground {CornSilk2} \
379 -background {Cornsilk2} \
380 -command {.frame.frame4.text0 yview} \
381 -foreground {#ffe4c4}
382
383 # build widget .frame.frame4.text0
384 text .frame.frame4.text0 \
385 -background {Cornsilk2} \
386 -font {8x16} \
387 -kanjifont {kanji16} \
388 -height {10} \
389 -selectbackground {#b2dfee} \
390 -selectborderwidth {1} \
391 -selectforeground {CornSilk2} \
392 -width {61} \
393 -yscrollcommand {.frame.frame4.scrollbar1 set}
394 # bindings
395 bind .frame.frame4.text0 <Button-2> {%W mark set insert @%x,%y
396 %W insert insert [selection get]
397 %W yview -pickplace insert}
398 bind .frame.frame4.text0 <Button-3> {%W mark set anchor insert
399 %W tag add sel insert @%x,%y}
400 bind .frame.frame4.text0 <Control-Key-a> {%W mark set insert {insert linestart}}
401 bind .frame.frame4.text0 <Control-Key-b> {%W mark set insert {insert -1char}}
402 bind .frame.frame4.text0 <Control-Key-d> {%W delete insert}
403 bind .frame.frame4.text0 <Control-Key-e> {%W mark set insert {insert lineend}}
404 bind .frame.frame4.text0 <Control-Key-f> {%W mark set insert {insert +1char}}
405 bind .frame.frame4.text0 <Control-Key-k> {if ![string compare [%W get insert] "\n"] {
406 %W delete insert} else {
407 %W delete insert {insert lineend}
408 }}
409 bind .frame.frame4.text0 <Control-Key-n> {%W mark set insert {insert +1line}}
410 bind .frame.frame4.text0 <Control-Key-p> {%W mark set insert {insert -1line}}
411 bind .frame.frame4.text0 <Control-Key-w> {if [llength [%W tag ranges sel]] {
412 %W delete sel.first sel.last
413 }}
414
415 # pack widget .frame.frame4
416 pack append .frame.frame4 \
417 .frame.frame4.text0 {left frame center expand fill} \
418 .frame.frame4.scrollbar1 {right frame center filly}
419
420 # pack widget .frame
421 pack append .frame \
422 .frame.frame0 {top frame center fillx} \
423 .frame.frame4 {left frame center expand fill}
424
425 # build widget .frame3
426 frame .frame3 \
427 -background {Cornsilk2} \
428 -borderwidth {2} \
429 -relief {raised}
430
431 # build widget .frame3.button4
432 button .frame3.button4 \
433 -activebackground {#eed5b7} \
434 -activeforeground {CornSilk2} \
435 -background {Cornsilk2} \
436 -command {lite quit 0
437 destroy .} \
438 -disabledforeground {#b0b0b0} \
439 -font {8x16} \
440 -kanjifont {kanji16} \
441 -text {Quit}
442
443 # build widget .frame3.checkbutton5
444 checkbutton .frame3.checkbutton5 \
445 -activebackground {#eed5b7} \
446 -activeforeground {CornSilk2} \
447 -background {Cornsilk2} \
448 -command {lite verbose "$verbose"} \
449 -disabledforeground {#b0b0b0} \
450 -font {8x16} \
451 -kanjifont {kanji16} \
452 -selector {#b03060} \
453 -text {verbose} \
454 -variable {verbose}
455
456 # build widget .frame3.button7
457 button .frame3.button7 \
458 -activebackground {#eed5b7} \
459 -activeforeground {CornSilk2} \
460 -background {Cornsilk2} \
461 -command {lite verify "{[$symbolicName(entry) get 0.0 end]}"} \
462 -disabledforeground {#b0b0b0} \
463 -font {8x16} \
464 -kanjifont {kanji16} \
465 -text {Verify}
466
467 # pack widget .frame3
468 pack append .frame3 \
469 .frame3.button4 {left frame center} \
470 .frame3.checkbutton5 {right frame center} \
471 .frame3.button7 {top frame n fillx}
472
473 # pack widget .
474 pack append . \
475 .frame {top frame center expand fill} \
476 .frame3 {top frame center fill}
477
478 .frame.frame4.text0 insert end {}
479
480
481
482 if {"[info procs XFEdit]" != ""} {
483 catch "XFMiscBindWidgetTree ."
484 after 2 "catch {XFEditSetShowWindows}"
485 }
486 }
487
488
489 # User defined procedures
490
491
492 # Procedure: FSBox
493 proc FSBox { {fsBoxMessage "Select file:"} {fsBoxFileName ""} {fsBoxActionOk ""} {fsBoxActionCancel ""}} {
494 # xf ignore me 5
495 ##########
496 # Procedure: FSBox
497 # Description: show file selector box
498 # Arguments: fsBoxMessage - the text to display
499 # fsBoxFileName - a file name that should be selected
500 # fsBoxActionOk - the action that should be performed on ok
501 # fsBoxActionCancel - the action that should be performed on cancel
502 # Returns: the filename that was selected, or nothing
503 # Sideeffects: none
504 ##########
505 #
506 # global fsBox(activeBackground) - active background color
507 # global fsBox(activeForeground) - active foreground color
508 # global fsBox(background) - background color
509 # global fsBox(font) - text font
510 # global fsBox(foreground) - foreground color
511 # global fsBox(extensions) - scan directory for extensions
512 # global fsBox(scrollActiveForeground) - scrollbar active background color
513 # global fsBox(scrollBackground) - scrollbar background color
514 # global fsBox(scrollForeground) - scrollbar foreground color
515 # global fsBox(scrollSide) - side where scrollbar is located
516
517 global fsBox
518
519 set tmpButtonOpt ""
520 set tmpFrameOpt ""
521 set tmpMessageOpt ""
522 set tmpScaleOpt ""
523 set tmpScrollOpt ""
524 if {"$fsBox(activeBackground)" != ""} {
525 append tmpButtonOpt "-activebackground \"$fsBox(activeBackground)\" "
526 }
527 if {"$fsBox(activeForeground)" != ""} {
528 append tmpButtonOpt "-activeforeground \"$fsBox(activeForeground)\" "
529 }
530 if {"$fsBox(background)" != ""} {
531 append tmpButtonOpt "-background \"$fsBox(background)\" "
532 append tmpFrameOpt "-background \"$fsBox(background)\" "
533 append tmpMessageOpt "-background \"$fsBox(background)\" "
534 }
535 if {"$fsBox(font)" != ""} {
536 append tmpButtonOpt "-font \"$fsBox(font)\" "
537 append tmpMessageOpt "-font \"$fsBox(font)\" "
538 }
539 if {"$fsBox(foreground)" != ""} {
540 append tmpButtonOpt "-foreground \"$fsBox(foreground)\" "
541 append tmpMessageOpt "-foreground \"$fsBox(foreground)\" "
542 }
543 if {"$fsBox(scrollActiveForeground)" != ""} {
544 append tmpScrollOpt "-activeforeground \"$fsBox(scrollActiveForeground)\" "
545 }
546 if {"$fsBox(scrollBackground)" != ""} {
547 append tmpScrollOpt "-background \"$fsBox(scrollBackground)\" "
548 }
549 if {"$fsBox(scrollForeground)" != ""} {
550 append tmpScrollOpt "-foreground \"$fsBox(scrollForeground)\" "
551 }
552
553 if {[file exists [file tail $fsBoxFileName]] &&
554 [IsAFile [file tail $fsBoxFileName]]} {
555 set fsBox(name) [file tail $fsBoxFileName]
556 } {
557 set fsBox(name) ""
558 }
559 if {[file exists $fsBoxFileName] && [IsADir $fsBoxFileName]} {
560 set fsBox(path) $fsBoxFileName
561 } {
562 if {"[file rootname $fsBoxFileName]" != "."} {
563 set fsBox(path) [file rootname $fsBoxFileName]
564 }
565 }
566 if {$fsBox(showPixmap)} {
567 set fsBox(path) [string trimleft $fsBox(path) @]
568 }
569 if {"$fsBox(path)" != "" && [file exists $fsBox(path)] &&
570 [IsADir $fsBox(path)]} {
571 set fsBox(internalPath) $fsBox(path)
572 } {
573 if {"$fsBox(internalPath)" == "" ||
574 ![file exists $fsBox(internalPath)]} {
575 set fsBox(internalPath) [pwd]
576 }
577 }
578 # build widget structure
579
580 # start build of toplevel
581 if {"[info commands XFDestroy]" != ""} {
582 catch {XFDestroy .fsBox}
583 } {
584 catch {destroy .fsBox}
585 }
586 toplevel .fsBox -borderwidth 0
587 catch ".fsBox config $tmpFrameOpt"
588 wm geometry .fsBox 350x300
589 wm title .fsBox {File select box}
590 wm maxsize .fsBox 1000 1000
591 wm minsize .fsBox 100 100
592 # end build of toplevel
593
594 label .fsBox.message1 -anchor c -relief raised -text "$fsBoxMessage"
595 catch ".fsBox.message1 config $tmpMessageOpt"
596
597 frame .fsBox.frame1 -borderwidth 0 -relief raised
598 catch ".fsBox.frame1 config $tmpFrameOpt"
599
600 button .fsBox.frame1.ok -text "OK" -command "
601 global fsBox
602 set fsBox(name) \[.fsBox.file.file get\]
603 if {$fsBox(showPixmap)} {
604 set fsBox(path) @\[.fsBox.path.path get\]
605 } {
606 set fsBox(path) \[.fsBox.path.path get\]
607 }
608 set fsBox(internalPath) \[.fsBox.path.path get\]
609 $fsBoxActionOk
610 if {\"\[info commands XFDestroy\]\" != \"\"} {
611 catch {XFDestroy .fsBox}
612 } {
613 catch {destroy .fsBox}
614 }"
615 catch ".fsBox.frame1.ok config $tmpButtonOpt"
616
617 button .fsBox.frame1.rescan -text "Rescan" -command {
618 global fsBox
619 FSBoxFSShow [.fsBox.path.path get] [.fsBox.pattern.pattern get] $fsBox(all)}
620 catch ".fsBox.frame1.rescan config $tmpButtonOpt"
621
622 button .fsBox.frame1.cancel -text "Cancel" -command "
623 global fsBox
624 set fsBox(name) {}
625 set fsBox(path) {}
626 $fsBoxActionCancel
627 if {\"\[info commands XFDestroy\]\" != \"\"} {
628 catch {XFDestroy .fsBox}
629 } {
630 catch {destroy .fsBox}
631 }"
632 catch ".fsBox.frame1.cancel config $tmpButtonOpt"
633
634 if {$fsBox(showPixmap)} {
635 frame .fsBox.frame2 -borderwidth 0 -relief raised
636 catch ".fsBox.frame2 config $tmpFrameOpt"
637
638 scrollbar .fsBox.frame2.scrollbar3 -command {.fsBox.frame2.canvas2 xview} -orient {horizontal} -relief {raised}
639 catch ".fsBox.frame2.scrollbar3 config $tmpScrollOpt"
640
641 scrollbar .fsBox.frame2.scrollbar1 -command {.fsBox.frame2.canvas2 yview} -relief {raised}
642 catch ".fsBox.frame2.scrollbar1 config $tmpScrollOpt"
643
644 canvas .fsBox.frame2.canvas2 -confine {true} -relief {raised} -scrollregion {0c 0c 20c 20c} -width {100} -xscrollcommand {.fsBox.frame2.scrollbar3 set} -yscrollcommand {.fsBox.frame2.scrollbar1 set}
645 catch ".fsBox.frame2.canvas2 config $tmpFrameOpt"
646
647 .fsBox.frame2.canvas2 addtag currentBitmap withtag [.fsBox.frame2.canvas2 create bitmap 5 5 -anchor nw]
648 }
649
650 frame .fsBox.path -borderwidth 0 -relief raised
651 catch ".fsBox.path config $tmpFrameOpt"
652
653 frame .fsBox.path.paths -borderwidth 2 -relief raised
654 catch ".fsBox.path.paths config $tmpFrameOpt"
655
656 menubutton .fsBox.path.paths.paths -borderwidth 0 -menu ".fsBox.path.paths.paths.menu" -relief flat -text "Pathname:"
657 catch ".fsBox.path.paths.paths config $tmpButtonOpt"
658
659 menu .fsBox.path.paths.paths.menu
660 catch ".fsBox.path.paths.paths.menu config $tmpButtonOpt"
661
662 .fsBox.path.paths.paths.menu add command -label "[string trimright $fsBox(internalPath) {/@}]" -command "
663 global fsBox
664 FSBoxFSShow \[.fsBox.path.path get\] \[.fsBox.pattern.pattern get\] \$fsBox(all)
665 .fsBox.path.path delete 0 end
666 .fsBox.path.path insert 0 [string trimright $fsBox(internalPath) {/@}]"
667
668 entry .fsBox.path.path -relief raised
669 catch ".fsBox.path.path config $tmpMessageOpt"
670
671 if {![IsADir $fsBox(internalPath)]} {
672 set $fsBox(internalPath) [pwd]
673 }
674 .fsBox.path.path insert 0 $fsBox(internalPath)
675
676 frame .fsBox.pattern -borderwidth 0 -relief raised
677 catch ".fsBox.pattern config $tmpFrameOpt"
678
679 frame .fsBox.pattern.patterns -borderwidth 2 -relief raised
680 catch ".fsBox.pattern.patterns config $tmpFrameOpt"
681
682 menubutton .fsBox.pattern.patterns.patterns -borderwidth 0 -menu ".fsBox.pattern.patterns.patterns.menu" -relief flat -text "Selection pattern:"
683 catch ".fsBox.pattern.patterns.patterns config $tmpButtonOpt"
684
685 menu .fsBox.pattern.patterns.patterns.menu
686 catch ".fsBox.pattern.patterns.patterns.menu config $tmpButtonOpt"
687
688 .fsBox.pattern.patterns.patterns.menu add checkbutton -label "Scan extensions" -variable fsBox(extensions) -command {
689 global fsBox
690 FSBoxFSShow [.fsBox.path.path get] [.fsBox.pattern.pattern get] $fsBox(all)}
691
692 entry .fsBox.pattern.pattern -relief raised
693 catch ".fsBox.pattern.pattern config $tmpMessageOpt"
694
695 .fsBox.pattern.pattern insert 0 $fsBox(pattern)
696
697 frame .fsBox.files -borderwidth 0 -relief raised
698 catch ".fsBox.files config $tmpFrameOpt"
699
700 scrollbar .fsBox.files.vscroll -relief raised -command ".fsBox.files.files yview"
701 catch ".fsBox.files.vscroll config $tmpScrollOpt"
702
703 scrollbar .fsBox.files.hscroll -orient horiz -relief raised -command ".fsBox.files.files xview"
704 catch ".fsBox.files.hscroll config $tmpScrollOpt"
705
706 listbox .fsBox.files.files -exportselection false -relief raised -xscrollcommand ".fsBox.files.hscroll set" -yscrollcommand ".fsBox.files.vscroll set"
707 catch ".fsBox.files.files config $tmpMessageOpt"
708
709 frame .fsBox.file -borderwidth 0 -relief raised
710 catch ".fsBox.file config $tmpFrameOpt"
711
712 label .fsBox.file.labelfile -relief raised -text "Filename:"
713 catch ".fsBox.file.labelfile config $tmpMessageOpt"
714
715 entry .fsBox.file.file -relief raised
716 catch ".fsBox.file.file config $tmpMessageOpt"
717
718 .fsBox.file.file delete 0 end
719 .fsBox.file.file insert 0 $fsBox(name)
720
721 checkbutton .fsBox.pattern.all -offvalue 0 -onvalue 1 -text "Show all files" -variable fsBox(all) -command {
722 global fsBox
723 FSBoxFSShow [.fsBox.path.path get] [.fsBox.pattern.pattern get] $fsBox(all)}
724 catch ".fsBox.pattern.all config $tmpButtonOpt"
725
726 FSBoxFSShow $fsBox(internalPath) $fsBox(pattern) $fsBox(all)
727
728 # bindings
729 bind .fsBox.files.files <Double-Button-1> "
730 FSBoxFSFileSelectDouble %W $fsBox(showPixmap) \{$fsBoxActionOk\} %y"
731 bind .fsBox.files.files <ButtonPress-1> "
732 FSBoxFSFileSelect %W $fsBox(showPixmap) %y"
733 bind .fsBox.files.files <Button1-Motion> "
734 FSBoxFSFileSelect %W $fsBox(showPixmap) %y"
735 bind .fsBox.files.files <Shift-Button1-Motion> "
736 FSBoxFSFileSelect %W $fsBox(showPixmap) %y"
737 bind .fsBox.files.files <Shift-ButtonPress-1> "
738 FSBoxFSFileSelect %W $fsBox(showPixmap) %y"
739
740 bind .fsBox.path.path <Tab> {
741 FSBoxFSNameComplete path}
742 bind .fsBox.path.path <Return> {
743 global tkVersion
744 global fsBox
745 FSBoxFSShow [.fsBox.path.path get] [.fsBox.pattern.pattern get] $fsBox(all)
746 FSBoxFSInsertPath
747 if {$tkVersion >= 3.0} {
748 .fsBox.file.file icursor end
749 } {
750 .fsBox.file.file cursor end
751 }
752 focus .fsBox.file.file}
753 catch "bind .fsBox.path.path <Up> {}"
754 bind .fsBox.path.path <Down> {
755 global tkVersion
756 if {$tkVersion >= 3.0} {
757 .fsBox.file.file icursor end
758 } {
759 .fsBox.file.file cursor end
760 }
761 focus .fsBox.file.file}
762
763 bind .fsBox.file.file <Tab> {
764 FSBoxFSNameComplete file}
765 bind .fsBox.file.file <Return> "
766 global fsBox
767 set fsBox(name) \[.fsBox.file.file get\]
768 if {$fsBox(showPixmap)} {
769 set fsBox(path) @\[.fsBox.path.path get\]
770 } {
771 set fsBox(path) \[.fsBox.path.path get\]
772 }
773 set fsBox(internalPath) \[.fsBox.path.path get\]
774 $fsBoxActionOk
775 if {\"\[info commands XFDestroy\]\" != \"\"} {
776 catch {XFDestroy .fsBox}
777 } {
778 catch {destroy .fsBox}
779 }"
780 bind .fsBox.file.file <Up> {
781 global tkVersion
782 if {$tkVersion >= 3.0} {
783 .fsBox.path.path icursor end
784 } {
785 .fsBox.path.path cursor end
786 }
787 focus .fsBox.path.path}
788 bind .fsBox.file.file <Down> {
789 global tkVersion
790 if {$tkVersion >= 3.0} {
791 .fsBox.pattern.pattern icursor end
792 } {
793 .fsBox.pattern.pattern cursor end
794 }
795 focus .fsBox.pattern.pattern}
796
797 bind .fsBox.pattern.pattern <Return> {
798 global fsBox
799 FSBoxFSShow [.fsBox.path.path get] [.fsBox.pattern.pattern get] $fsBox(all)}
800 bind .fsBox.pattern.pattern <Up> {
801 global tkVersion
802 if {$tkVersion >= 3.0} {
803 .fsBox.file.file icursor end
804 } {
805 .fsBox.file.file cursor end
806 }
807 focus .fsBox.file.file}
808 catch "bind .fsBox.pattern.pattern <Down> {}"
809
810 # packing
811 pack append .fsBox.files .fsBox.files.vscroll "$fsBox(scrollSide) filly" .fsBox.files.hscroll {bottom fillx} .fsBox.files.files {left fill expand}
812 pack append .fsBox.file .fsBox.file.labelfile {left} .fsBox.file.file {left fill expand}
813 pack append .fsBox.frame1 .fsBox.frame1.ok {left fill expand} .fsBox.frame1.rescan {left fill expand} .fsBox.frame1.cancel {left fill expand}
814 pack append .fsBox.path.paths .fsBox.path.paths.paths {left}
815 pack append .fsBox.pattern.patterns .fsBox.pattern.patterns.patterns {left}
816 pack append .fsBox.path .fsBox.path.paths {left} .fsBox.path.path {left fill expand}
817 pack append .fsBox.pattern .fsBox.pattern.patterns {left} .fsBox.pattern.all {right fill} .fsBox.pattern.pattern {left fill expand}
818 if {$fsBox(showPixmap)} {
819 pack append .fsBox.frame2 .fsBox.frame2.scrollbar1 {left filly} .fsBox.frame2.canvas2 {top expand fill} .fsBox.frame2.scrollbar3 {top fillx}
820
821 pack append .fsBox .fsBox.message1 {top fill} .fsBox.frame1 {bottom fill} .fsBox.pattern {bottom fill} .fsBox.file {bottom fill} .fsBox.path {bottom fill} .fsBox.frame2 {right fill} .fsBox.files {left fill expand}
822 } {
823 pack append .fsBox .fsBox.message1 {top fill} .fsBox.frame1 {bottom fill} .fsBox.pattern {bottom fill} .fsBox.file {bottom fill} .fsBox.path {bottom fill} .fsBox.files {left fill expand}
824 }
825
826 if {"$fsBoxActionOk" == "" && "$fsBoxActionCancel" == ""} {
827 # wait for the box to be destroyed
828 update idletask
829 grab .fsBox
830 tkwait window .fsBox
831
832 if {"[string trim $fsBox(path)]" != "" ||
833 "[string trim $fsBox(name)]" != ""} {
834 if {"[string trimleft [string trim $fsBox(name)] /]" == ""} {
835 return [string trimright [string trim $fsBox(path)] /]
836 } {
837 return [string trimright [string trim $fsBox(path)] /]/[string trimleft [string trim $fsBox(name)] /]
838 }
839 }
840 }
841 }
842
843
844 # Procedure: FSBoxBindSelectOne
845 proc FSBoxBindSelectOne { fsBoxW fsBoxY} {
846 # xf ignore me 6
847
848 set fsBoxNearest [$fsBoxW nearest $fsBoxY]
849 if {$fsBoxNearest >= 0} {
850 $fsBoxW select from $fsBoxNearest
851 $fsBoxW select to $fsBoxNearest
852 }
853 }
854
855
856 # Procedure: FSBoxFSFileSelect
857 proc FSBoxFSFileSelect { fsBoxW fsBoxShowPixmap fsBoxY} {
858 # xf ignore me 6
859 global fsBox
860
861 FSBoxBindSelectOne $fsBoxW $fsBoxY
862 set fsBoxNearest [$fsBoxW nearest $fsBoxY]
863 if {$fsBoxNearest >= 0} {
864 set fsBoxTmpEntry [$fsBoxW get $fsBoxNearest]
865 if {"[string index $fsBoxTmpEntry [expr [string length $fsBoxTmpEntry]-1]]" == "/" ||
866 "[string index $fsBoxTmpEntry [expr [string length $fsBoxTmpEntry]-1]]" == "@"} {
867 set fsBoxFileName [string range $fsBoxTmpEntry 0 [expr [string length $fsBoxTmpEntry]-2]]
868 if {![IsADir [string trimright $fsBox(internalPath)/$fsBoxFileName @]] &&
869 ![IsASymlink [string trimright $fsBox(internalPath)/$fsBoxFileName @]]} {
870 set fsBoxFileName $fsBoxTmpEntry
871 }
872 } {
873 if {"[string index $fsBoxTmpEntry [expr [string length $fsBoxTmpEntry]-1]]" == "*"} {
874 set fsBoxFileName [string range $fsBoxTmpEntry 0 [expr [string length $fsBoxTmpEntry]-2]]
875 if {![file executable $fsBox(internalPath)/$fsBoxFileName]} {
876 set fsBoxFileName $fsBoxTmpEntry
877 }
878 } {
879 set fsBoxFileName $fsBoxTmpEntry
880 }
881 }
882 if {![IsADir [string trimright $fsBox(internalPath)/$fsBoxFileName @]]} {
883 set fsBox(name) $fsBoxFileName
884 .fsBox.file.file delete 0 end
885 .fsBox.file.file insert 0 $fsBox(name)
886 if {$fsBoxShowPixmap} {
887 catch ".fsBox.frame2.canvas2 itemconfigure currentBitmap -bitmap \"@$fsBox(internalPath)/$fsBox(name)\""
888 }
889 }
890 }
891 }
892
893
894 # Procedure: FSBoxFSFileSelectDouble
895 proc FSBoxFSFileSelectDouble { fsBoxW fsBoxShowPixmap fsBoxAction fsBoxY} {
896 # xf ignore me 6
897 global fsBox
898
899 FSBoxBindSelectOne $fsBoxW $fsBoxY
900 set fsBoxNearest [$fsBoxW nearest $fsBoxY]
901 if {$fsBoxNearest >= 0} {
902 set fsBoxTmpEntry [$fsBoxW get $fsBoxNearest]
903 if {"$fsBoxTmpEntry" == "../"} {
904 set fsBoxTmpEntry [string trimright [string trim $fsBox(internalPath)] "@/"]
905 if {"$fsBoxTmpEntry" == ""} {
906 return
907 }
908 FSBoxFSShow [file dirname $fsBoxTmpEntry] [.fsBox.pattern.pattern get] $fsBox(all)
909 .fsBox.path.path delete 0 end
910 .fsBox.path.path insert 0 $fsBox(internalPath)
911 } {
912 if {"[string index $fsBoxTmpEntry [expr [string length $fsBoxTmpEntry]-1]]" == "/" ||
913 "[string index $fsBoxTmpEntry [expr [string length $fsBoxTmpEntry]-1]]" == "@"} {
914 set fsBoxFileName [string range $fsBoxTmpEntry 0 [expr [string length $fsBoxTmpEntry]-2]]
915 if {![IsADir [string trimright $fsBox(internalPath)/$fsBoxFileName @]] &&
916 ![IsASymlink [string trimright $fsBox(internalPath)/$fsBoxFileName @]]} {
917 set fsBoxFileName $fsBoxTmpEntry
918 }
919 } {
920 if {"[string index $fsBoxTmpEntry [expr [string length $fsBoxTmpEntry]-1]]" == "*"} {
921 set fsBoxFileName [string range $fsBoxTmpEntry 0 [expr [string length $fsBoxTmpEntry]-2]]
922 if {![file executable $fsBox(internalPath)/$fsBoxFileName]} {
923 set fsBoxFileName $fsBoxTmpEntry
924 }
925 } {
926 set fsBoxFileName $fsBoxTmpEntry
927 }
928 }
929 if {[IsADir [string trimright $fsBox(internalPath)/$fsBoxFileName @]]} {
930 set fsBox(internalPath) "[string trimright $fsBox(internalPath) {/@}]/$fsBoxFileName"
931 FSBoxFSShow $fsBox(internalPath) [.fsBox.pattern.pattern get] $fsBox(all)
932 .fsBox.path.path delete 0 end
933 .fsBox.path.path insert 0 $fsBox(internalPath)
934 } {
935 set fsBox(name) $fsBoxFileName
936 if {$fsBoxShowPixmap} {
937 set fsBox(path) @$fsBox(internalPath)
938 } {
939 set fsBox(path) $fsBox(internalPath)
940 }
941 if {"$fsBoxAction" != ""} {
942 eval "global fsBox; $fsBoxAction"
943 }
944 if {"[info commands XFDestroy]" != ""} {
945 catch {XFDestroy .fsBox}
946 } {
947 catch {destroy .fsBox}
948 }
949 }
950 }
951 }
952 }
953
954
955 # Procedure: FSBoxFSInsertPath
956 proc FSBoxFSInsertPath {} {
957 # xf ignore me 6
958 global fsBox
959
960 set fsBoxLast [.fsBox.path.paths.paths.menu index last]
961 set fsBoxNewEntry [string trimright [.fsBox.path.path get] "/@"]
962 for {set fsBoxCounter 0} {$fsBoxCounter <= $fsBoxLast} {incr fsBoxCounter 1} {
963 if {"$fsBoxNewEntry" == "[lindex [.fsBox.path.paths.paths.menu entryconfigure $fsBoxCounter -label] 4]"} {
964 return
965 }
966 }
967 if {$fsBoxLast < 9} {
968 .fsBox.path.paths.paths.menu add command -label "$fsBoxNewEntry" -command "
969 global fsBox
970 FSBoxFSShow $fsBoxNewEntry \[.fsBox.pattern.pattern get\] \$fsBox(all)
971 .fsBox.path.path delete 0 end
972 .fsBox.path.path insert 0 $fsBoxNewEntry"
973 } {
974 for {set fsBoxCounter 0} {$fsBoxCounter < $fsBoxLast} {incr fsBoxCounter 1} {
975 .fsBox.path.paths.paths.menu entryconfigure $fsBoxCounter -label [lindex [.fsBox.path.paths.paths.menu entryconfigure [expr $fsBoxCounter+1] -label] 4]
976 .fsBox.path.paths.paths.menu entryconfigure $fsBoxCounter -command "
977 global fsBox
978 FSBoxFSShow [lindex [.fsBox.path.paths.paths.menu entryconfigure [expr $fsBoxCounter+1] -label] 4] \[.fsBox.pattern.pattern get\] \$fsBox(all)
979 .fsBox.path.path delete 0 end
980 .fsBox.path.path insert 0 [lindex [.fsBox.path.paths.paths.menu entryconfigure [expr $fsBoxCounter+1] -label] 4]"
981 }
982 .fsBox.path.paths.paths.menu entryconfigure $fsBoxLast -label "$fsBoxNewEntry"
983 .fsBox.path.paths.paths.menu entryconfigure $fsBoxCounter -command "
984 global fsBox
985 FSBoxFSShow \[.fsBox.path.path get\] \[.fsBox.pattern.pattern get\] \$fsBox(all)
986 .fsBox.path.path delete 0 end
987 .fsBox.path.path insert 0 $fsBoxNewEntry"
988 }
989 }
990
991
992 # Procedure: FSBoxFSNameComplete
993 proc FSBoxFSNameComplete { fsBoxType} {
994 # xf ignore me 6
995 global tkVersion
996 global fsBox
997
998 set fsBoxNewFile ""
999 if {"$fsBoxType" == "path"} {
1000 set fsBoxDirName [file dirname [.fsBox.path.path get]]
1001 set fsBoxFileName [file tail [.fsBox.path.path get]]
1002 } {
1003 set fsBoxDirName [file dirname [.fsBox.path.path get]/]
1004 set fsBoxFileName [file tail [.fsBox.file.file get]]
1005 }
1006
1007 set fsBoxNewFile ""
1008 if {[IsADir [string trimright $fsBoxDirName @]]} {
1009 catch "glob -nocomplain $fsBoxDirName/${fsBoxFileName}*" fsBoxResult
1010 foreach fsBoxCounter $fsBoxResult {
1011 if {"$fsBoxNewFile" == ""} {
1012 set fsBoxNewFile [file tail $fsBoxCounter]
1013 } {
1014 if {"[string index [file tail $fsBoxCounter] 0]" !=
1015 "[string index $fsBoxNewFile 0]"} {
1016 set fsBoxNewFile ""
1017 break
1018 }
1019 set fsBoxCounter1 0
1020 set fsBoxTmpFile1 $fsBoxNewFile
1021 set fsBoxTmpFile2 [file tail $fsBoxCounter]
1022 set fsBoxLength1 [string length $fsBoxTmpFile1]
1023 set fsBoxLength2 [string length $fsBoxTmpFile2]
1024 set fsBoxNewFile ""
1025 if {$fsBoxLength1 > $fsBoxLength2} {
1026 set fsBoxLength1 $fsBoxLength2
1027 }
1028 while {$fsBoxCounter1 < $fsBoxLength1} {
1029 if {"[string index $fsBoxTmpFile1 $fsBoxCounter1]" == "[string index $fsBoxTmpFile2 $fsBoxCounter1]"} {
1030 append fsBoxNewFile [string index $fsBoxTmpFile1 $fsBoxCounter1]
1031 } {
1032 break
1033 }
1034 incr fsBoxCounter1 1
1035 }
1036 }
1037 }
1038 }
1039 if {"$fsBoxNewFile" != ""} {
1040 if {[IsADir [string trimright $fsBoxDirName/$fsBoxNewFile @]] ||
1041 ![IsAFile [string trimright $fsBoxDirName/$fsBoxNewFile @]]} {
1042 if {[IsADir [string trimright $fsBoxDirName/$fsBoxNewFile @]]} {
1043 if {"$fsBoxDirName" == "/"} {
1044 .fsBox.path.path delete 0 end
1045 .fsBox.path.path insert 0 "/[string trimright [string trim $fsBoxNewFile /] @]/"
1046 } {
1047 .fsBox.path.path delete 0 end
1048 .fsBox.path.path insert 0 "[string trimright $fsBoxDirName /]/[string trimright [string trim $fsBoxNewFile /] @]/"
1049 }
1050 FSBoxFSShow [.fsBox.path.path get] [.fsBox.pattern.pattern get] $fsBox(all)
1051 FSBoxFSInsertPath
1052 } {
1053 .fsBox.path.path delete 0 end
1054 .fsBox.path.path insert 0 "[string trimright $fsBoxDirName /]/[string trimright [string trim $fsBoxNewFile /] @]"
1055 }
1056 } {
1057 .fsBox.path.path delete 0 end
1058 .fsBox.path.path insert 0 "[string trimright $fsBoxDirName {@/}]/"
1059 .fsBox.file.file delete 0 end
1060 .fsBox.file.file insert 0 $fsBoxNewFile
1061 if {$tkVersion >= 3.0} {
1062 .fsBox.file.file icursor end
1063 } {
1064 .fsBox.file.file cursor end
1065 }
1066 focus .fsBox.file.file
1067 }
1068 }
1069 }
1070
1071
1072 # Procedure: FSBoxFSShow
1073 proc FSBoxFSShow { fsBoxPath fsBoxPattern fsBoxAll} {
1074 # xf ignore me 6
1075 global fsBox
1076
1077 set tmpButtonOpt ""
1078 if {"$fsBox(activeBackground)" != ""} {
1079 append tmpButtonOpt "-activebackground \"$fsBox(activeBackground)\" "
1080 }
1081 if {"$fsBox(activeForeground)" != ""} {
1082 append tmpButtonOpt "-activeforeground \"$fsBox(activeForeground)\" "
1083 }
1084 if {"$fsBox(background)" != ""} {
1085 append tmpButtonOpt "-background \"$fsBox(background)\" "
1086 }
1087 if {"$fsBox(font)" != ""} {
1088 append tmpButtonOpt "-font \"$fsBox(font)\" "
1089 }
1090 if {"$fsBox(foreground)" != ""} {
1091 append tmpButtonOpt "-foreground \"$fsBox(foreground)\" "
1092 }
1093
1094 set fsBox(pattern) $fsBoxPattern
1095 if {[file exists $fsBoxPath] && [file readable $fsBoxPath] &&
1096 [IsADir $fsBoxPath]} {
1097 set fsBox(internalPath) $fsBoxPath
1098 } {
1099 if {[file exists $fsBoxPath] && [file readable $fsBoxPath] &&
1100 [IsAFile $fsBoxPath]} {
1101 set fsBox(internalPath) [file dirname $fsBoxPath]
1102 .fsBox.file.file delete 0 end
1103 .fsBox.file.file insert 0 [file tail $fsBoxPath]
1104 set fsBoxPath $fsBox(internalPath)
1105 } {
1106 while {"$fsBoxPath" != "" && "$fsBoxPath" != "/" &&
1107 ![file isdirectory $fsBoxPath]} {
1108 set fsBox(internalPath) [file dirname $fsBoxPath]
1109 set fsBoxPath $fsBox(internalPath)
1110 }
1111 }
1112 }
1113 if {"$fsBoxPath" == ""} {
1114 set fsBoxPath "/"
1115 set fsBox(internalPath) "/"
1116 }
1117 .fsBox.path.path delete 0 end
1118 .fsBox.path.path insert 0 $fsBox(internalPath)
1119
1120 if {[.fsBox.files.files size] > 0} {
1121 .fsBox.files.files delete 0 end
1122 }
1123 if {$fsBoxAll} {
1124 if {[catch "exec ls -F -a $fsBoxPath" fsBoxResult]} {
1125 puts stderr "$fsBoxResult"
1126 }
1127 } {
1128 if {[catch "exec ls -F $fsBoxPath" fsBoxResult]} {
1129 puts stderr "$fsBoxResult"
1130 }
1131 }
1132 set fsBoxElementList [lsort $fsBoxResult]
1133
1134 foreach fsBoxCounter [winfo children .fsBox.pattern.patterns.patterns] {
1135 if {[string length [info commands XFDestroy]] > 0} {
1136 catch {XFDestroy $fsBoxCounter}
1137 } {
1138 catch {destroy $fsBoxCounter}
1139 }
1140 }
1141 menu .fsBox.pattern.patterns.patterns.menu
1142 catch ".fsBox.pattern.patterns.patterns.menu config $tmpButtonOpt"
1143
1144 if {$fsBox(extensions)} {
1145 .fsBox.pattern.patterns.patterns.menu add command -label "*" -command {
1146 global fsBox
1147 set fsBox(pattern) "*"
1148 .fsBox.pattern.pattern delete 0 end
1149 .fsBox.pattern.pattern insert 0 $fsBox(pattern)
1150 FSBoxFSShow [.fsBox.path.path get] $fsBox(pattern) $fsBox(all)}
1151 }
1152
1153 if {"$fsBoxPath" != "/"} {
1154 .fsBox.files.files insert end "../"
1155 }
1156 foreach fsBoxCounter $fsBoxElementList {
1157 if {[string match $fsBoxPattern $fsBoxCounter] ||
1158 [IsADir [string trimright $fsBoxPath/$fsBoxCounter "/@"]]} {
1159 if {"$fsBoxCounter" != "../" &&
1160 "$fsBoxCounter" != "./"} {
1161 .fsBox.files.files insert end $fsBoxCounter
1162 }
1163 }
1164
1165 if {$fsBox(extensions)} {
1166 catch "file rootname $fsBoxCounter" fsBoxRootName
1167 catch "file extension $fsBoxCounter" fsBoxExtension
1168 set fsBoxExtension [string trimright $fsBoxExtension "/*@"]
1169 if {"$fsBoxExtension" != "" && "$fsBoxRootName" != ""} {
1170 set fsBoxInsert 1
1171 set fsBoxLast [.fsBox.pattern.patterns.patterns.menu index last]
1172 for {set fsBoxCounter1 0} {$fsBoxCounter1 <= $fsBoxLast} {incr fsBoxCounter1 1} {
1173 if {"*$fsBoxExtension" == "[lindex [.fsBox.pattern.patterns.patterns.menu entryconfigure $fsBoxCounter1 -label] 4]"} {
1174 set fsBoxInsert 0
1175 }
1176 }
1177 if {$fsBoxInsert} {
1178 .fsBox.pattern.patterns.patterns.menu add command -label "*$fsBoxExtension" -command "
1179 global fsBox
1180 set fsBox(pattern) \"*$fsBoxExtension\"
1181 .fsBox.pattern.pattern delete 0 end
1182 .fsBox.pattern.pattern insert 0 \$fsBox(pattern)
1183 FSBoxFSShow \[.fsBox.path.path get\] \$fsBox(pattern) \$fsBox(all)"
1184 }
1185 }
1186 }
1187 }
1188 if {$fsBox(extensions)} {
1189 .fsBox.pattern.patterns.patterns.menu add separator
1190 }
1191 if {$fsBox(extensions) ||
1192 "[.fsBox.pattern.patterns.patterns.menu index last]" == "none"} {
1193 .fsBox.pattern.patterns.patterns.menu add checkbutton -label "Scan extensions" -variable "fsBox(extensions)" -command {
1194 global fsBox
1195 FSBoxFSShow [.fsBox.path.path get] [.fsBox.pattern.pattern get] $fsBox(all)}
1196 }
1197 }
1198
1199
1200 # Procedure: InputBoxInternal
1201 proc InputBoxInternal { inputBoxMessage inputBoxCommandOk inputBoxCommandCancel inputBoxGeometry inputBoxTitle lineNum} {
1202 # xf ignore me 6
1203 global inputBox
1204
1205 set tmpButtonOpt ""
1206 set tmpFrameOpt ""
1207 set tmpMessageOpt ""
1208 set tmpScaleOpt ""
1209 set tmpScrollOpt ""
1210 if {"$inputBox(activeBackground)" != ""} {
1211 append tmpButtonOpt "-activebackground \"$inputBox(activeBackground)\" "
1212 }
1213 if {"$inputBox(activeForeground)" != ""} {
1214 append tmpButtonOpt "-activeforeground \"$inputBox(activeForeground)\" "
1215 }
1216 if {"$inputBox(background)" != ""} {
1217 append tmpButtonOpt "-background \"$inputBox(background)\" "
1218 append tmpFrameOpt "-background \"$inputBox(background)\" "
1219 append tmpMessageOpt "-background \"$inputBox(background)\" "
1220 }
1221 if {"$inputBox(font)" != ""} {
1222 append tmpButtonOpt "-font \"$inputBox(font)\" "
1223 append tmpMessageOpt "-font \"$inputBox(font)\" "
1224 }
1225 if {"$inputBox(foreground)" != ""} {
1226 append tmpButtonOpt "-foreground \"$inputBox(foreground)\" "
1227 append tmpMessageOpt "-foreground \"$inputBox(foreground)\" "
1228 }
1229 if {"$inputBox(scrollActiveForeground)" != ""} {
1230 append tmpScrollOpt "-activeforeground \"$inputBox(scrollActiveForeground)\" "
1231 }
1232 if {"$inputBox(scrollBackground)" != ""} {
1233 append tmpScrollOpt "-background \"$inputBox(scrollBackground)\" "
1234 }
1235 if {"$inputBox(scrollForeground)" != ""} {
1236 append tmpScrollOpt "-foreground \"$inputBox(scrollForeground)\" "
1237 }
1238
1239 # start build of toplevel
1240 if {"[info commands XFDestroy]" != ""} {
1241 catch {XFDestroy $inputBox(toplevelName)}
1242 } {
1243 catch {destroy $inputBox(toplevelName)}
1244 }
1245 toplevel $inputBox(toplevelName) -borderwidth 0
1246 catch "$inputBox(toplevelName) config $tmpFrameOpt"
1247 if {[catch "wm geometry $inputBox(toplevelName) $inputBoxGeometry"]} {
1248 wm geometry $inputBox(toplevelName) 350x150
1249 }
1250 wm title $inputBox(toplevelName) $inputBoxTitle
1251 wm maxsize $inputBox(toplevelName) 1000 1000
1252 wm minsize $inputBox(toplevelName) 100 100
1253 # end build of toplevel
1254
1255 message $inputBox(toplevelName).message1 -anchor "$inputBox(anchor)" -justify "$inputBox(justify)" -relief raised -text "$inputBoxMessage"
1256 catch "$inputBox(toplevelName).message1 config $tmpMessageOpt"
1257
1258 set xfTmpWidth [string range $inputBoxGeometry 0 [expr [string first x $inputBoxGeometry]-1]]
1259 if {"$xfTmpWidth" != ""} {
1260 # set message size
1261 catch "$inputBox(toplevelName).message1 configure -width [expr $xfTmpWidth-10]"
1262 } {
1263 $inputBox(toplevelName).message1 configure -aspect 1500
1264 }
1265
1266 frame $inputBox(toplevelName).frame0 -borderwidth 0 -relief raised
1267 catch "$inputBox(toplevelName).frame0 config $tmpFrameOpt"
1268
1269 frame $inputBox(toplevelName).frame1 -borderwidth 0 -relief raised
1270 catch "$inputBox(toplevelName).frame1 config $tmpFrameOpt"
1271
1272 if {$lineNum == 1} {
1273 scrollbar $inputBox(toplevelName).frame1.hscroll -orient "horizontal" -relief raised -command "$inputBox(toplevelName).frame1.input view"
1274 catch "$inputBox(toplevelName).frame1.hscroll config $tmpScrollOpt"
1275
1276 entry $inputBox(toplevelName).frame1.input -relief raised -scrollcommand "$inputBox(toplevelName).frame1.hscroll set"
1277 catch "$inputBox(toplevelName).frame1.input config $tmpMessageOpt"
1278
1279 $inputBox(toplevelName).frame1.input insert 0 $inputBox($inputBox(toplevelName),inputOne)
1280
1281 # bindings
1282 bind $inputBox(toplevelName).frame1.input <Return> "
1283 global inputBox
1284 set inputBox($inputBox(toplevelName),inputOne) \[$inputBox(toplevelName).frame1.input get\]
1285 if {\"\[info commands XFDestroy\]\" != \"\"} {
1286 catch {XFDestroy $inputBox(toplevelName)}
1287 } {
1288 catch {destroy $inputBox(toplevelName)}
1289 }
1290 $inputBoxCommandOk"
1291
1292 # packing
1293 pack append $inputBox(toplevelName).frame1 $inputBox(toplevelName).frame1.hscroll {bottom fill} $inputBox(toplevelName).frame1.input {top fill expand}
1294 } {
1295 text $inputBox(toplevelName).frame1.input -relief raised -wrap none -borderwidth 2 -yscrollcommand "$inputBox(toplevelName).frame1.vscroll set"
1296 catch "$inputBox(toplevelName).frame1.input config $tmpMessageOpt"
1297
1298 scrollbar $inputBox(toplevelName).frame1.vscroll -relief raised -command "$inputBox(toplevelName).frame1.input yview"
1299 catch "$inputBox(toplevelName).frame1.vscroll config $tmpScrollOpt"
1300
1301 $inputBox(toplevelName).frame1.input insert 1.0 $inputBox($inputBox(toplevelName),inputMulti)
1302
1303 # bindings
1304 bind $inputBox(toplevelName).frame1.input <Control-Return> "
1305 global inputBox
1306 set inputBox($inputBox(toplevelName),inputMulti) \[$inputBox(toplevelName).frame1.input get 1.0 end\]
1307 if {\"\[info commands XFDestroy\]\" != \"\"} {
1308 catch {XFDestroy $inputBox(toplevelName)}
1309 } {
1310 catch {destroy $inputBox(toplevelName)}
1311 }
1312 $inputBoxCommandOk"
1313 bind $inputBox(toplevelName).frame1.input <Meta-Return> "
1314 global inputBox
1315 set inputBox($inputBox(toplevelName),inputMulti) \[$inputBox(toplevelName).frame1.input get 1.0 end\]
1316 if {\"\[info commands XFDestroy\]\" != \"\"} {
1317 catch {XFDestroy $inputBox(toplevelName)}
1318 } {
1319 catch {destroy $inputBox(toplevelName)}
1320 }
1321 $inputBoxCommandOk"
1322
1323 # packing
1324 pack append $inputBox(toplevelName).frame1 $inputBox(toplevelName).frame1.vscroll "$inputBox(scrollSide) filly" $inputBox(toplevelName).frame1.input {left fill expand}
1325 }
1326
1327 button $inputBox(toplevelName).frame0.button0 -text "OK" -command "
1328 global inputBox
1329 if {$lineNum == 1} {
1330 set inputBox($inputBox(toplevelName),inputOne) \[$inputBox(toplevelName).frame1.input get\]
1331 } {
1332 set inputBox($inputBox(toplevelName),inputMulti) \[$inputBox(toplevelName).frame1.input get 1.0 end\]
1333 }
1334 if {\"\[info commands XFDestroy\]\" != \"\"} {
1335 catch {XFDestroy $inputBox(toplevelName)}
1336 } {
1337 catch {destroy $inputBox(toplevelName)}
1338 }
1339 $inputBoxCommandOk"
1340 catch "$inputBox(toplevelName).frame0.button0 config $tmpButtonOpt"
1341
1342 button $inputBox(toplevelName).frame0.button1 -text "Cancel" -command "
1343 global inputBox
1344 if {$lineNum == 1} {
1345 set inputBox($inputBox(toplevelName),inputOne) \"\"
1346 } {
1347 set inputBox($inputBox(toplevelName),inputMulti) \"\"
1348 }
1349 if {\"\[info commands XFDestroy\]\" != \"\"} {
1350 catch {XFDestroy $inputBox(toplevelName)}
1351 } {
1352 catch {destroy $inputBox(toplevelName)}
1353 }
1354 $inputBoxCommandCancel"
1355 catch "$inputBox(toplevelName).frame0.button1 config $tmpButtonOpt"
1356
1357 pack append $inputBox(toplevelName).frame0 $inputBox(toplevelName).frame0.button0 {left fill expand} $inputBox(toplevelName).frame0.button1 {left fill expand}
1358
1359 pack append $inputBox(toplevelName) $inputBox(toplevelName).frame0 {bottom fill} $inputBox(toplevelName).frame1 {bottom fill expand} $inputBox(toplevelName).message1 {top fill}
1360 }
1361
1362
1363 # Procedure: InputBoxMulti
1364 proc InputBoxMulti { {inputBoxMessage "Input box:"} {inputBoxCommandOk ""} {inputBoxCommandCancel ""} {inputBoxGeometry "350x150"} {inputBoxTitle "Input box"}} {
1365 # xf ignore me 5
1366 ##########
1367 # Procedure: InputBoxMulti
1368 # Description: show input box with one text line
1369 # Arguments: {inputBoxMessage} - message to display
1370 # {inputBoxCommandOk} - the command to call after ok
1371 # {inputBoxCommandCancel} - the command to call after cancel
1372 # {inputBoxGeometry} - the geometry for the window
1373 # {inputBoxTitle} - the title for the window
1374 # Returns: The entered text
1375 # Sideeffects: none
1376 # Notes: there exist also a function called:
1377 # InputBoxOne - to enter one line text
1378 ##########
1379 #
1380 # global inputBox(activeBackground) - active background color
1381 # global inputBox(activeForeground) - active foreground color
1382 # global inputBox(anchor) - anchor for message box
1383 # global inputBox(background) - background color
1384 # global inputBox(erase) - erase previous text
1385 # global inputBox(font) - message font
1386 # global inputBox(foreground) - foreground color
1387 # global inputBox(justify) - justify for message box
1388 # global inputBox(scrollActiveForeground) - scrollbar active background color
1389 # global inputBox(scrollBackground) - scrollbar background color
1390 # global inputBox(scrollForeground) - scrollbar foreground color
1391 # global inputBox(scrollSide) - side where scrollbar is located
1392 # global inputBox(toplevelName) - the toplevel name
1393 # global inputBox(toplevelName,inputMulti) - the text in the text widget
1394
1395 global inputBox
1396
1397 if {"$inputBoxGeometry" == ""} {
1398 set inputBoxGeometry 350x150
1399 }
1400 if {$inputBox(erase)} {
1401 set inputBox($inputBox(toplevelName),inputMulti) ""
1402 } {
1403 if {![info exists inputBox($inputBox(toplevelName),inputMulti)]} {
1404 set inputBox($inputBox(toplevelName),inputMulti) ""
1405 }
1406 }
1407 InputBoxInternal $inputBoxMessage $inputBoxCommandOk $inputBoxCommandCancel $inputBoxGeometry $inputBoxTitle 2
1408
1409 # wait for the box to be destroyed
1410 update idletask
1411 grab $inputBox(toplevelName)
1412 tkwait window $inputBox(toplevelName)
1413
1414 return $inputBox($inputBox(toplevelName),inputMulti)
1415 }
1416
1417
1418 # Procedure: InputBoxOne
1419 proc InputBoxOne { {inputBoxMessage "Input box:"} {inputBoxCommandOk ""} {inputBoxCommandCancel ""} {inputBoxGeometry "350x150"} {inputBoxTitle "Input box"}} {
1420 # xf ignore me 5
1421 ##########
1422 # Procedure: InputBoxOne
1423 # Description: show input box with one text line
1424 # Arguments: {inputBoxMessage} - message to display
1425 # {inputBoxCommandOk} - the command to call after ok
1426 # {inputBoxCommandCancel} - the command to call after cancel
1427 # {inputBoxGeometry} - the geometry for the window
1428 # {inputBoxTitle} - the title for the window
1429 # Returns: The entered text
1430 # Sideeffects: none
1431 # Notes: there exist also a function called:
1432 # InputBoxMulti - to enter multiline text
1433 ##########
1434 #
1435 # global inputBox(activeBackground) - active background color
1436 # global inputBox(activeForeground) - active foreground color
1437 # global inputBox(anchor) - anchor for message box
1438 # global inputBox(background) - background color
1439 # global inputBox(erase) - erase previous text
1440 # global inputBox(font) - message font
1441 # global inputBox(foreground) - foreground color
1442 # global inputBox(justify) - justify for message box
1443 # global inputBox(scrollActiveForeground) - scrollbar active background color
1444 # global inputBox(scrollBackground) - scrollbar background color
1445 # global inputBox(scrollForeground) - scrollbar foreground color
1446 # global inputBox(scrollSide) - side where scrollbar is located
1447 # global inputBox(toplevelName) - the toplevel name
1448 # global inputBox(toplevelName,inputOne) - the text in the entry widget
1449
1450 global inputBox
1451
1452 if {$inputBox(erase)} {
1453 set inputBox($inputBox(toplevelName),inputOne) ""
1454 } {
1455 if {![info exists inputBox($inputBox(toplevelName),inputOne)]} {
1456 set inputBox($inputBox(toplevelName),inputOne) ""
1457 }
1458 }
1459 InputBoxInternal $inputBoxMessage $inputBoxCommandOk $inputBoxCommandCancel $inputBoxGeometry $inputBoxTitle 1
1460
1461 # wait for the box to be destroyed
1462 update idletask
1463 grab $inputBox(toplevelName)
1464 tkwait window $inputBox(toplevelName)
1465
1466 return $inputBox($inputBox(toplevelName),inputOne)
1467 }
1468
1469
1470 # Procedure: IsADir
1471 proc IsADir { pathName} {
1472 # xf ignore me 5
1473 ##########
1474 # Procedure: IsADir
1475 # Description: check if name is a directory (including symbolic links)
1476 # Arguments: pathName - the path to check
1477 # Returns: 1 if its a directory, otherwise 0
1478 # Sideeffects: none
1479 ##########
1480
1481 if {[file isdirectory $pathName]} {
1482 return 1
1483 } {
1484 catch "file type $pathName" fileType
1485 if {"$fileType" == "link"} {
1486 if {[catch "file readlink $pathName" linkName]} {
1487 return 0
1488 }
1489 catch "file type $linkName" fileType
1490 while {"$fileType" == "link"} {
1491 if {[catch "file readlink $linkName" linkName]} {
1492 return 0
1493 }
1494 catch "file type $linkName" fileType
1495 }
1496 return [file isdirectory $linkName]
1497 }
1498 }
1499 return 0
1500 }
1501
1502
1503 # Procedure: IsAFile
1504 proc IsAFile { fileName} {
1505 # xf ignore me 5
1506 ##########
1507 # Procedure: IsAFile
1508 # Description: check if filename is a file (including symbolic links)
1509 # Arguments: fileName - the filename to check
1510 # Returns: 1 if its a file, otherwise 0
1511 # Sideeffects: none
1512 ##########
1513
1514 if {[file isfile $fileName]} {
1515 return 1
1516 } {
1517 catch "file type $fileName" fileType
1518 if {"$fileType" == "link"} {
1519 if {[catch "file readlink $fileName" linkName]} {
1520 return 0
1521 }
1522 catch "file type $linkName" fileType
1523 while {"$fileType" == "link"} {
1524 if {[catch "file readlink $linkName" linkName]} {
1525 return 0
1526 }
1527 catch "file type $linkName" fileType
1528 }
1529 return [file isfile $linkName]
1530 }
1531 }
1532 return 0
1533 }
1534
1535
1536 # Procedure: IsASymlink
1537 proc IsASymlink { fileName} {
1538 # xf ignore me 5
1539 ##########
1540 # Procedure: IsASymlink
1541 # Description: check if filename is a symbolic link
1542 # Arguments: fileName - the path/filename to check
1543 # Returns: none
1544 # Sideeffects: none
1545 ##########
1546
1547 catch "file type $fileName" fileType
1548 if {"$fileType" == "link"} {
1549 return 1
1550 }
1551 return 0
1552 }
1553
1554
1555 # Procedure: PrologCommand
1556 proc PrologCommand {} {
1557 prolog {prolog_call [InputBoxOne "Prolog Command:"]} lite
1558 }
1559
1560
1561 # Procedure: TokioCommand
1562 proc TokioCommand {} {
1563 prolog {tokio_call [InputBoxOne "Tokio Command:"]} lite
1564 }
1565
1566
1567 # Procedure: canvaswh
1568 proc canvaswh { c scale} {
1569 global scalex scaley
1570 if {! $scalex && ! $scaley } {
1571 regexp {([0-9]+)x([0-9]+)} [wm geometry .] dm w h
1572 set h [$c canvasy [expr $h/2]]
1573 set w [$c canvasx [expr $w/2]]
1574 } else {
1575 set h $scaley
1576 set w $scalex
1577 }
1578 $c scale all $w $h $scale $scale
1579 }
1580
1581
1582 # Procedure: crosshair
1583 proc crosshair { c x y} {
1584 global scalex scaley
1585 if {[$c find withtag cursol] != {}} {
1586 $c delete cursol
1587 }
1588 set cs 5
1589 set x [$c canvasx $x]
1590 set y [$c canvasy $y]
1591 $c create line $x [expr $y - $cs] $x [expr $y + $cs] -tags cursol
1592 $c create line [expr $x - $cs] $y [expr $x + $cs] $y -tags cursol
1593 set scalex $x
1594 set scaley $y
1595 }
1596
1597
1598 # Procedure: event
1599 proc event { args now} {
1600 prolog "tokio_event $args $now" tokio
1601 }
1602
1603
1604 # Procedure: filehandling
1605 proc filehandling { t mode file} {
1606 if {[string compare $mode "load"] == 0} {
1607 if [file isfile $file] {
1608 $t delete 0.0 end
1609 set F [open $file r]
1610 while {[gets $F string] != -1} {
1611 $t insert end "$string\n"
1612 }
1613 close $F
1614 }
1615 } else {
1616 set line [$t get 0.0 end]
1617 # if [file writable $dir] {
1618 if [expr [llength $line] > 0] {
1619 set F [open $file w]
1620 puts $F $line
1621 close $F
1622 }
1623 # }
1624 }
1625 }
1626
1627
1628 # Procedure: lite
1629 proc lite { a b} {
1630 prolog "event $a $b" lite
1631 }
1632
1633
1634 # Procedure: text_clear
1635 proc text_clear { t} {
1636 $t delete 0.0 end
1637 }
1638
1639
1640 # Internal procedures
1641
1642
1643 # Procedure: Alias
1644 if {"[info procs Alias]" == ""} {
1645 proc Alias { args} {
1646 # xf ignore me 7
1647 ##########
1648 # Procedure: Alias
1649 # Description: establish an alias for a procedure
1650 # Arguments: args - no argument means that a list of all aliases
1651 # is returned. Otherwise the first parameter is
1652 # the alias name, and the second parameter is
1653 # the procedure that is aliased.
1654 # Returns: nothing, the command that is bound to the alias or a
1655 # list of all aliases - command pairs.
1656 # Sideeffects: internalAliasList is updated, and the alias
1657 # proc is inserted
1658 ##########
1659 global internalAliasList
1660
1661 if {[llength $args] == 0} {
1662 return $internalAliasList
1663 } {
1664 if {[llength $args] == 1} {
1665 set xfTmpIndex [lsearch $internalAliasList "[lindex $args 0] *"]
1666 if {$xfTmpIndex != -1} {
1667 return [lindex [lindex $internalAliasList $xfTmpIndex] 1]
1668 }
1669 } {
1670 if {[llength $args] == 2} {
1671 eval "proc [lindex $args 0] {args} {#xf ignore me 4
1672 return \[eval \"[lindex $args 1] \$args\"\]}"
1673 set xfTmpIndex [lsearch $internalAliasList "[lindex $args 0] *"]
1674 if {$xfTmpIndex != -1} {
1675 set internalAliasList [lreplace $internalAliasList $xfTmpIndex $xfTmpIndex "[lindex $args 0] [lindex $args 1]"]
1676 } {
1677 lappend internalAliasList "[lindex $args 0] [lindex $args 1]"
1678 }
1679 } {
1680 error "Alias: wrong number or args: $args"
1681 }
1682 }
1683 }
1684 }
1685 }
1686
1687
1688 # Procedure: GetSelection
1689 if {"[info procs GetSelection]" == ""} {
1690 proc GetSelection {} {
1691 # xf ignore me 7
1692 ##########
1693 # Procedure: GetSelection
1694 # Description: get current selection
1695 # Arguments: none
1696 # Returns: none
1697 # Sideeffects: none
1698 ##########
1699
1700 # the save way
1701 set xfSelection ""
1702 catch "selection get" xfSelection
1703 if {"$xfSelection" == "selection doesn't exist or form \"STRING\" not defined"} {
1704 return ""
1705 } {
1706 return $xfSelection
1707 }
1708 }
1709 }
1710
1711
1712 # Procedure: MenuPopupAdd
1713 if {"[info procs MenuPopupAdd]" == ""} {
1714 proc MenuPopupAdd { xfW xfButton xfMenu {xfModifier ""} {xfCanvasTag ""}} {
1715 # xf ignore me 7
1716 # the popup menu handling is from (I already gave up with popup handling :-):
1717 #
1718 # Copyright 1991,1992 by James Noble.
1719 # Everyone is granted permission to copy, modify and redistribute.
1720 # This notice must be preserved on all copies or derivates.
1721 #
1722 ##########
1723 # Procedure: MenuPopupAdd
1724 # Description: attach a popup menu to widget
1725 # Arguments: xfW - the widget
1726 # xfButton - the button we use
1727 # xfMenu - the menu to attach
1728 # {xfModifier} - a optional modifier
1729 # {xfCanvasTag} - a canvas tagOrId
1730 # Returns: none
1731 # Sideeffects: none
1732 ##########
1733 global tk_popupPriv
1734
1735 set tk_popupPriv($xfMenu,focus) ""
1736 set tk_popupPriv($xfMenu,grab) ""
1737 if {"$xfModifier" != ""} {
1738 set press "$xfModifier-"
1739 set motion "$xfModifier-"
1740 set release "Any-"
1741 } {
1742 set press ""
1743 set motion ""
1744 set release ""
1745 }
1746
1747 bind $xfMenu "<${motion}B${xfButton}-Motion>" "MenuPopupMotion $xfMenu %W %X %Y"
1748 bind $xfMenu "<${release}ButtonRelease-${xfButton}>" "MenuPopupRelease $xfMenu %W"
1749 if {"$xfCanvasTag" == ""} {
1750 bind $xfW "<${press}ButtonPress-${xfButton}>" "MenuPopupPost $xfMenu %X %Y"
1751 bind $xfW "<${release}ButtonRelease-${xfButton}>" "MenuPopupRelease $xfMenu %W"
1752 } {
1753 $xfW bind $xfCanvasTag "<${press}ButtonPress-${xfButton}>" "MenuPopupPost $xfMenu %X %Y"
1754 $xfW bind $xfCanvasTag "<${release}ButtonRelease-${xfButton}>" "MenuPopupRelease $xfMenu %W"
1755 }
1756 }
1757 }
1758
1759
1760 # Procedure: MenuPopupMotion
1761 if {"[info procs MenuPopupMotion]" == ""} {
1762 proc MenuPopupMotion { xfMenu xfW xfX xfY} {
1763 # xf ignore me 7
1764 ##########
1765 # Procedure: MenuPopupMotion
1766 # Description: handle the popup menu motion
1767 # Arguments: xfMenu - the topmost menu
1768 # xfW - the menu
1769 # xfX - the root x coordinate
1770 # xfY - the root x coordinate
1771 # Returns: none
1772 # Sideeffects: none
1773 ##########
1774 global tk_popupPriv
1775
1776 if {"[info commands $xfW]" != "" && [winfo ismapped $xfW] &&
1777 "[winfo class $xfW]" == "Menu" &&
1778 [info exists tk_popupPriv($xfMenu,focus)] &&
1779 "$tk_popupPriv($xfMenu,focus)" != "" &&
1780 [info exists tk_popupPriv($xfMenu,grab)] &&
1781 "$tk_popupPriv($xfMenu,grab)" != ""} {
1782 set xfPopMinX [winfo rootx $xfW]
1783 set xfPopMaxX [expr $xfPopMinX+[winfo width $xfW]]
1784 if {$xfX >= $xfPopMinX && $xfX <= $xfPopMaxX} {
1785 $xfW activate @[expr $xfY-[winfo rooty $xfW]]
1786 if {![catch "$xfW entryconfig @[expr $xfY-[winfo rooty $xfW]] -menu" result]} {
1787 if {"[lindex $result 4]" != ""} {
1788 foreach binding [bind $xfMenu] {
1789 bind [lindex $result 4] $binding [bind $xfMenu $binding]
1790 }
1791 }
1792 }
1793 } {
1794 $xfW activate none
1795 }
1796 }
1797 }
1798 }
1799
1800
1801 # Procedure: MenuPopupPost
1802 if {"[info procs MenuPopupPost]" == ""} {
1803 proc MenuPopupPost { xfMenu xfX xfY} {
1804 # xf ignore me 7
1805 ##########
1806 # Procedure: MenuPopupPost
1807 # Description: post the popup menu
1808 # Arguments: xfMenu - the menu
1809 # xfX - the root x coordinate
1810 # xfY - the root x coordinate
1811 # Returns: none
1812 # Sideeffects: none
1813 ##########
1814 global tk_popupPriv
1815
1816 if {"[info commands $xfMenu]" != ""} {
1817 if {![info exists tk_popupPriv($xfMenu,focus)]} {
1818 set tk_popupPriv($xfMenu,focus) [focus]
1819 } {
1820 if {"$tk_popupPriv($xfMenu,focus)" == ""} {
1821 set tk_popupPriv($xfMenu,focus) [focus]
1822 }
1823 }
1824 set tk_popupPriv($xfMenu,grab) $xfMenu
1825
1826 catch "$xfMenu activate none"
1827 catch "$xfMenu post $xfX $xfY"
1828 catch "focus $xfMenu"
1829 catch "grab -global $xfMenu"
1830 }
1831 }
1832 }
1833
1834
1835 # Procedure: MenuPopupRelease
1836 if {"[info procs MenuPopupRelease]" == ""} {
1837 proc MenuPopupRelease { xfMenu xfW} {
1838 # xf ignore me 7
1839 ##########
1840 # Procedure: MenuPopupRelease
1841 # Description: remove the popup menu
1842 # Arguments: xfMenu - the topmost menu widget
1843 # xfW - the menu widget
1844 # Returns: none
1845 # Sideeffects: none
1846 ##########
1847 global tk_popupPriv
1848 global tkVersion
1849
1850 if {"[info commands $xfW]" != "" && [winfo ismapped $xfW] &&
1851 "[winfo class $xfW]" == "Menu" &&
1852 [info exists tk_popupPriv($xfMenu,focus)] &&
1853 "$tk_popupPriv($xfMenu,focus)" != "" &&
1854 [info exists tk_popupPriv($xfMenu,grab)] &&
1855 "$tk_popupPriv($xfMenu,grab)" != ""} {
1856 if {$tkVersion >= 3.0} {
1857 catch "grab release $tk_popupPriv($xfMenu,grab)"
1858 } {
1859 catch "grab none"
1860 }
1861 catch "focus $tk_popupPriv($xfMenu,focus)"
1862 set tk_popupPriv($xfMenu,focus) ""
1863 set tk_popupPriv($xfMenu,grab) ""
1864 if {"[$xfW index active]" != "none"} {
1865 $xfW invoke active; catch "$xfMenu unpost"
1866 }
1867 }
1868 catch "$xfMenu unpost"
1869 }
1870 }
1871
1872
1873 # Procedure: NoFunction
1874 if {"[info procs NoFunction]" == ""} {
1875 proc NoFunction { args} {
1876 # xf ignore me 7
1877 ##########
1878 # Procedure: NoFunction
1879 # Description: do nothing (especially with scales and scrollbars)
1880 # Arguments: args - a number of ignored parameters
1881 # Returns: none
1882 # Sideeffects: none
1883 ##########
1884 }
1885 }
1886
1887
1888 # Procedure: SN
1889 if {"[info procs SN]" == ""} {
1890 proc SN { {xfName ""}} {
1891 # xf ignore me 7
1892 ##########
1893 # Procedure: SN
1894 # Description: map a symbolic name to the widget path
1895 # Arguments: xfName
1896 # Returns: the symbolic name
1897 # Sideeffects: none
1898 ##########
1899
1900 SymbolicName $xfName
1901 }
1902 }
1903
1904
1905 # Procedure: SymbolicName
1906 if {"[info procs SymbolicName]" == ""} {
1907 proc SymbolicName { {xfName ""}} {
1908 # xf ignore me 7
1909 ##########
1910 # Procedure: SymbolicName
1911 # Description: map a symbolic name to the widget path
1912 # Arguments: xfName
1913 # Returns: the symbolic name
1914 # Sideeffects: none
1915 ##########
1916
1917 global symbolicName
1918
1919 if {"$xfName" != ""} {
1920 set xfArrayName ""
1921 append xfArrayName symbolicName ( $xfName )
1922 if {![catch "set \"$xfArrayName\"" xfValue]} {
1923 return $xfValue
1924 } {
1925 if {"[info commands XFProcError]" != ""} {
1926 XFProcError "Unknown symbolic name:\n$xfName"
1927 } {
1928 puts stderr "XF error: unknown symbolic name:\n$xfName"
1929 }
1930 }
1931 }
1932 return ""
1933 }
1934 }
1935
1936
1937 # Procedure: Unalias
1938 if {"[info procs Unalias]" == ""} {
1939 proc Unalias { aliasName} {
1940 # xf ignore me 7
1941 ##########
1942 # Procedure: Unalias
1943 # Description: remove an alias for a procedure
1944 # Arguments: aliasName - the alias name to remove
1945 # Returns: none
1946 # Sideeffects: internalAliasList is updated, and the alias
1947 # proc is removed
1948 ##########
1949 global internalAliasList
1950
1951 set xfIndex [lsearch $internalAliasList "$aliasName *"]
1952 if {$xfIndex != -1} {
1953 rename $aliasName ""
1954 set internalAliasList [lreplace $internalAliasList $xfIndex $xfIndex]
1955 }
1956 }
1957 }
1958
1959
1960
1961 # application parsing procedure
1962 proc XFLocalParseAppDefs {xfAppDefFile} {
1963 global xfAppDefaults
1964
1965 # basically from: Michael Moore
1966 if {[file exists $xfAppDefFile] &&
1967 [file readable $xfAppDefFile] &&
1968 "[file type $xfAppDefFile]" == "link"} {
1969 catch "file type $xfAppDefFile" xfType
1970 while {"$xfType" == "link"} {
1971 if {[catch "file readlink $xfAppDefFile" xfAppDefFile]} {
1972 return
1973 }
1974 catch "file type $xfAppDefFile" xfType
1975 }
1976 }
1977 if {!("$xfAppDefFile" != "" &&
1978 [file exists $xfAppDefFile] &&
1979 [file readable $xfAppDefFile] &&
1980 "[file type $xfAppDefFile]" == "file")} {
1981 return
1982 }
1983 if {![catch "open $xfAppDefFile r" xfResult]} {
1984 set xfAppFileContents [read $xfResult]
1985 close $xfResult
1986 foreach line [split $xfAppFileContents "\n"] {
1987 # backup indicates how far to backup. It applies to the
1988 # situation where a resource name ends in . and when it
1989 # ends in *. In the second case you want to keep the *
1990 # in the widget name for pattern matching, but you want
1991 # to get rid of the . if it is the end of the name.
1992 set backup -2
1993 set line [string trim $line]
1994 if {[string index $line 0] == "#" || "$line" == ""} {
1995 # skip comments and empty lines
1996 continue
1997 }
1998 set list [split $line ":"]
1999 set resource [string trim [lindex $list 0]]
2000 set i [string last "." $resource]
2001 set j [string last "*" $resource]
2002 if {$j > $i} {
2003 set i $j
2004 set backup -1
2005 }
2006 incr i
2007 set name [string range $resource $i end]
2008 incr i $backup
2009 set widname [string range $resource 0 $i]
2010 set value [string trim [lindex $list 1]]
2011 if {"$widname" != "" && "$widname" != "*"} {
2012 # insert the widget and resourcename to the application
2013 # defaults list.
2014 if {![info exists xfAppDefaults]} {
2015 set xfAppDefaults ""
2016 }
2017 lappend xfAppDefaults [list $widname [string tolower $name] $value]
2018 }
2019 }
2020 }
2021 }
2022
2023 # application loading procedure
2024 proc XFLocalLoadAppDefs {{xfClasses ""} {xfPriority "startupFile"} {xfAppDefFile ""}} {
2025 global env
2026
2027 if {"$xfAppDefFile" == ""} {
2028 set xfFileList ""
2029 if {[info exists env(XUSERFILESEARCHPATH)]} {
2030 append xfFileList [split $env(XUSERFILESEARCHPATH) :]
2031 }
2032 if {[info exists env(XAPPLRESDIR)]} {
2033 append xfFileList [split $env(XAPPLRESDIR) :]
2034 }
2035 if {[info exists env(XFILESEARCHPATH)]} {
2036 append xfFileList [split $env(XFILESEARCHPATH) :]
2037 }
2038 append xfFileList " /usr/lib/X11/app-defaults"
2039 append xfFileList " /usr/X11/lib/X11/app-defaults"
2040
2041 foreach xfCounter1 $xfClasses {
2042 foreach xfCounter2 $xfFileList {
2043 set xfPathName $xfCounter2
2044 if {[regsub -all "%N" "$xfPathName" "$xfCounter1" xfResult]} {
2045 set xfPathName $xfResult
2046 }
2047 if {[regsub -all "%T" "$xfPathName" "app-defaults" xfResult]} {
2048 set xfPathName $xfResult
2049 }
2050 if {[regsub -all "%S" "$xfPathName" "" xfResult]} {
2051 set xfPathName $xfResult
2052 }
2053 if {[regsub -all "%C" "$xfPathName" "" xfResult]} {
2054 set xfPathName $xfResult
2055 }
2056 if {[file exists $xfPathName] &&
2057 [file readable $xfPathName] &&
2058 ("[file type $xfPathName]" == "file" ||
2059 "[file type $xfPathName]" == "link")} {
2060 catch "option readfile $xfPathName $xfPriority"
2061 if {"[info commands XFParseAppDefs]" != ""} {
2062 XFParseAppDefs $xfPathName
2063 } {
2064 if {"[info commands XFLocalParseAppDefs]" != ""} {
2065 XFLocalParseAppDefs $xfPathName
2066 }
2067 }
2068 } {
2069 if {[file exists $xfCounter2/$xfCounter1] &&
2070 [file readable $xfCounter2/$xfCounter1] &&
2071 ("[file type $xfCounter2/$xfCounter1]" == "file" ||
2072 "[file type $xfCounter2/$xfCounter1]" == "link")} {
2073 catch "option readfile $xfCounter2/$xfCounter1 $xfPriority"
2074 if {"[info commands XFParseAppDefs]" != ""} {
2075 XFParseAppDefs $xfCounter2/$xfCounter1
2076 } {
2077 if {"[info commands XFLocalParseAppDefs]" != ""} {
2078 XFLocalParseAppDefs $xfCounter2/$xfCounter1
2079 }
2080 }
2081 }
2082 }
2083 }
2084 }
2085 } {
2086 # load a specific application defaults file
2087 if {[file exists $xfAppDefFile] &&
2088 [file readable $xfAppDefFile] &&
2089 ("[file type $xfAppDefFile]" == "file" ||
2090 "[file type $xfAppDefFile]" == "link")} {
2091 catch "option readfile $xfAppDefFile $xfPriority"
2092 if {"[info commands XFParseAppDefs]" != ""} {
2093 XFParseAppDefs $xfAppDefFile
2094 } {
2095 if {"[info commands XFLocalParseAppDefs]" != ""} {
2096 XFLocalParseAppDefs $xfAppDefFile
2097 }
2098 }
2099 }
2100 }
2101 }
2102
2103 # application setting procedure
2104 proc XFLocalSetAppDefs {{xfWidgetPath "."}} {
2105 global xfAppDefaults
2106
2107 if {![info exists xfAppDefaults]} {
2108 return
2109 }
2110 foreach xfCounter $xfAppDefaults {
2111 if {"$xfCounter" == ""} {
2112 break
2113 }
2114 set widname [lindex $xfCounter 0]
2115 if {[string match $widname ${xfWidgetPath}] ||
2116 [string match "${xfWidgetPath}*" $widname]} {
2117 set name [string tolower [lindex $xfCounter 1]]
2118 set value [lindex $xfCounter 2]
2119 # Now lets see how many tcl commands match the name
2120 # pattern specified.
2121 set widlist [info command $widname]
2122 if {"$widlist" != ""} {
2123 foreach widget $widlist {
2124 # make sure this command is a widget.
2125 if {![catch "winfo id $widget"] &&
2126 [string match "${xfWidgetPath}*" $widget]} {
2127 catch "$widget configure -$name $value"
2128 }
2129 }
2130 }
2131 }
2132 }
2133 }
2134
2135
2136 # prepare auto loading
2137 global auto_path
2138 global tk_library
2139 global xfLoadPath
2140 foreach xfElement [eval list [split $xfLoadPath :] $auto_path] {
2141 if {[file exists $xfElement/tclIndex]} {
2142 lappend auto_path $xfElement
2143 }
2144 }
2145 catch "unset auto_index"
2146
2147 catch "unset auto_oldpath"
2148
2149 catch "unset auto_execs"
2150
2151
2152 # initialize global variables
2153 proc InitGlobals {} {
2154 global {checkbutton5}
2155 set {checkbutton5} {0}
2156 global {fsBox}
2157 set {fsBox(activeBackground)} {}
2158 set {fsBox(activeForeground)} {}
2159 set {fsBox(all)} {0}
2160 set {fsBox(background)} {}
2161 set {fsBox(button)} {0}
2162 set {fsBox(extensions)} {0}
2163 set {fsBox(font)} {}
2164 set {fsBox(foreground)} {}
2165 set {fsBox(internalPath)} {/user/kono/ITL/demo}
2166 set {fsBox(name)} {ahoaho}
2167 set {fsBox(path)} {/user/kono/ITL/demo}
2168 set {fsBox(pattern)} {*}
2169 set {fsBox(scrollActiveForeground)} {}
2170 set {fsBox(scrollBackground)} {}
2171 set {fsBox(scrollForeground)} {}
2172 set {fsBox(scrollSide)} {left}
2173 set {fsBox(showPixmap)} {0}
2174 global {inputBox}
2175 set {inputBox(activeBackground)} {}
2176 set {inputBox(activeForeground)} {}
2177 set {inputBox(anchor)} {n}
2178 set {inputBox(background)} {}
2179 set {inputBox(erase)} {1}
2180 set {inputBox(font)} {}
2181 set {inputBox(foreground)} {}
2182 set {inputBox(justify)} {center}
2183 set {inputBox(scrollActiveForeground)} {}
2184 set {inputBox(scrollBackground)} {}
2185 set {inputBox(scrollForeground)} {}
2186 set {inputBox(scrollSide)} {left}
2187 set {inputBox(toplevelName)} {.inputBox}
2188 global {scalex}
2189 set {scalex} {326}
2190 global {scaley}
2191 set {scaley} {194}
2192 global {verbose}
2193 set {verbose} {0}
2194
2195 # please don't modify the following
2196 # variables. They are needed by xf.
2197 global {autoLoadList}
2198 set {autoLoadList(xf-disp)} {0}
2199 global {internalAliasList}
2200 set {internalAliasList} {}
2201 global {moduleList}
2202 set {moduleList(xf-disp)} {}
2203 global {preloadList}
2204 set {preloadList(xfInternal)} {}
2205 global {symbolicName}
2206 set {symbolicName(canvas)} {.top0.frame0.canvas2}
2207 set {symbolicName(diag)} {.top0.frame6.button8}
2208 set {symbolicName(entry)} {.frame.frame4.text0}
2209 set {symbolicName(execute)} {.top0.frame6.button10}
2210 set {symbolicName(generate)} {.top0.frame1.button0}
2211 set {symbolicName(map)} {.top0.frame1.button13}
2212 set {symbolicName(root)} {.}
2213 set {symbolicName(states)} {.top0.frame1.label6}
2214 set {symbolicName(verbose)} {.frame3.checkbutton5}
2215 set {symbolicName(verify)} {.frame3.button7}
2216 global {xfWmSetPosition}
2217 set {xfWmSetPosition} {}
2218 global {xfWmSetSize}
2219 set {xfWmSetSize} {}
2220 global {xfAppDefToplevels}
2221 set {xfAppDefToplevels} {}
2222 }
2223
2224 # initialize global variables
2225 InitGlobals
2226
2227 # display/remove toplevel windows.
2228 ShowWindow.
2229
2230 global xfShowWindow.top0
2231 set xfShowWindow.top0 1
2232 ShowWindow.top0
2233
2234 # load default bindings.
2235 if {[info exists env(XF_BIND_FILE)] &&
2236 "[info procs XFShowHelp]" == ""} {
2237 source $env(XF_BIND_FILE)
2238 }
2239
2240 # parse and apply application defaults.
2241 XFLocalLoadAppDefs Xf-disp
2242 XFLocalSetAppDefs
2243
2244 # eof
2245 #
2246