Mercurial > hg > Applications > Lite
changeset 18:a6adedccd5f6
*** empty log message ***
| author | kono |
|---|---|
| date | Sun, 21 Jan 2001 10:21:43 +0900 |
| parents | a9c1a72bc6a1 |
| children | e1d3145cff7a |
| files | cad.pl test tmp.pl xf-disp |
| diffstat | 3 files changed, 0 insertions(+), 2283 deletions(-) [+] |
line wrap: on
line diff
--- a/cad.pl Sun Jan 21 10:21:24 2001 +0900 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,31 +0,0 @@ -specification(Z=f(X), - while(more,(( - Z=X, - ( - (X->( - repeat((skip&(Z=X,empty)),until,not(X)) & - repeat((skip&(Z=not(X),empty)),until,not(X)))) - , - (not(X)->( - repeat((skip&(Z=not(X),empty)),until,not(X)))) - ) - & skip - ))) -). - -implementation(Z=f(X), - exists(y,( - not(y), - []( - ( - next(y) = ((not(X),not(y));(X,y)), - Z = ((X,not(y);(not(X),y))) - ) - ) - )) -). - -?- specification(z=f(x),Y),ex((trace(x,[1,1,0,1,1,1,0,0,1,0,1]),Y)). - -?- speficication(z=f(x),S),implementation(z=f(x),I), - ex(I->fin_free(S)).
--- a/tmp.pl Sun Jan 21 10:21:24 2001 +0900 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,6 +0,0 @@ -tmp(( -not(true& ?(^r,not(@ @ @ @empty),@ @ @ @empty)&true); -?(r^1, - (not(true_false&true);not(r^2&true);not(r^1&true)), - (not(true_false&true);not(r^2&true);r^2 & ^r,not(r^1&true))))). -
--- a/xf-disp Sun Jan 21 10:21:24 2001 +0900 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,2246 +0,0 @@ -#!/usr/local/bin/wish -f -# Program: xf-disp -# Tcl version: 7.3 (Tcl/Tk/XF) -# Tk version: 3.6 -# XF version: 2.2 -# - -# module inclusion -global env -global xfLoadPath -global xfLoadInfo -set xfLoadInfo 0 -if {[info exists env(XF_LOAD_PATH)]} { - if {[string first $env(XF_LOAD_PATH) /usr/local/lib/] == -1} { - set xfLoadPath $env(XF_LOAD_PATH):/usr/local/lib/ - } { - set xfLoadPath /usr/local/lib/ - } -} { - set xfLoadPath /usr/local/lib/ -} - -global argc -global argv -global tkVersion -set tmpArgv "" -for {set counter 0} {$counter < $argc} {incr counter 1} { - case [string tolower [lindex $argv $counter]] in { - {-xfloadpath} { - incr counter 1 - set xfLoadPath "[lindex $argv $counter]:$xfLoadPath" - } - {-xfstartup} { - incr counter 1 - source [lindex $argv $counter] - } - {-xfbindfile} { - incr counter 1 - set env(XF_BIND_FILE) "[lindex $argv $counter]" - } - {-xfcolorfile} { - incr counter 1 - set env(XF_COLOR_FILE) "[lindex $argv $counter]" - } - {-xfcursorfile} { - incr counter 1 - set env(XF_CURSOR_FILE) "[lindex $argv $counter]" - } - {-xffontfile} { - incr counter 1 - set env(XF_FONT_FILE) "[lindex $argv $counter]" - } - {-xfmodelmono} { - if {$tkVersion >= 3.0} { - tk colormodel . monochrome - } - } - {-xfmodelcolor} { - if {$tkVersion >= 3.0} { - tk colormodel . color - } - } - {-xfloading} { - set xfLoadInfo 1 - } - {-xfnoloading} { - set xfLoadInfo 0 - } - {default} { - lappend tmpArgv [lindex $argv $counter] - } - } -} -set argv $tmpArgv -set argc [llength $tmpArgv] -unset counter -unset tmpArgv - - -# procedure to show window .top0 -proc ShowWindow.top0 {args} {# xf ignore me 7 - - # build widget .top0 - if {"[info procs XFEdit]" != ""} { - catch "XFDestroy .top0" - } { - catch "destroy .top0" - } - toplevel .top0 \ - -background {Cornsilk2} - - # Window manager configurations - global tkVersion - wm positionfrom .top0 "" - wm sizefrom .top0 "" - wm maxsize .top0 1000 1000 - wm minsize .top0 10 10 - wm title .top0 {Execution} - - - # build widget .top0.frame0 - frame .top0.frame0 \ - -background {Cornsilk2} \ - -relief {raised} - - # build widget .top0.frame0.scrollbar3 - scrollbar .top0.frame0.scrollbar3 \ - -activeforeground {CornSilk2} \ - -background {Cornsilk2} \ - -command {.top0.frame0.canvas2 xview} \ - -foreground {#ffe4c4} \ - -orient {horizontal} \ - -relief {raised} - - # build widget .top0.frame0.scrollbar1 - scrollbar .top0.frame0.scrollbar1 \ - -activeforeground {CornSilk2} \ - -background {Cornsilk2} \ - -command {.top0.frame0.canvas2 yview} \ - -foreground {#ffe4c4} \ - -relief {raised} - - # build widget .top0.frame0.canvas2 - canvas .top0.frame0.canvas2 \ - -background {Cornsilk2} \ - -confine {0} \ - -height {384} \ - -insertofftime {600} \ - -relief {raised} \ - -scrollregion {-1c -1c 20c 20c} \ - -selectbackground {#b2dfee} \ - -selectborderwidth {1} \ - -selectforeground {CornSilk2} \ - -width {394} \ - -xscrollcommand {.top0.frame0.scrollbar3 set} \ - -yscrollcommand {.top0.frame0.scrollbar1 set} - # bindings - bind .top0.frame0.canvas2 <Button-1> {crosshair .top0.frame0.canvas2 %x %y} - - # pack widget .top0.frame0 - pack append .top0.frame0 \ - .top0.frame0.scrollbar1 {right frame center filly} \ - .top0.frame0.canvas2 {top frame center expand fill} \ - .top0.frame0.scrollbar3 {top frame center fillx} - - # build widget .top0.frame1 - frame .top0.frame1 \ - -background {Cornsilk2} \ - -borderwidth {2} \ - -relief {raised} - - # build widget .top0.frame1.label6 - label .top0.frame1.label6 \ - -anchor {w} \ - -background {Cornsilk2} \ - -font {8x16} \ - -kanjifont {kanji16} \ - -relief {raised} \ - -text {States:} - - # build widget .top0.frame1.button13 - button .top0.frame1.button13 \ - -activebackground {#eed5b7} \ - -activeforeground {CornSilk2} \ - -background {Cornsilk2} \ - -command {# regexp {([0-9]+)x([0-9]+)} [wm geometry .] dm width height -# set height [expr $height-300] -# lite map $height - lite map 300 -} \ - -disabledforeground {#b0b0b0} \ - -font {8x16} \ - -kanjifont {kanji16} \ - -text {Map} - - # build widget .top0.frame1.button0 - button .top0.frame1.button0 \ - -activeforeground {CornSilk2} \ - -background {Cornsilk2} \ - -command {lite generate a} \ - -font {8x16} \ - -kanjifont {*-fixed-*-normal--16-*-jisx0208.1983-*} \ - -text {Generate} - - # pack widget .top0.frame1 - pack append .top0.frame1 \ - .top0.frame1.label6 {left frame center expand fillx} \ - .top0.frame1.button13 {left frame center} \ - .top0.frame1.button0 {left frame center fillx} - - # build widget .top0.frame6 - frame .top0.frame6 \ - -background {Cornsilk2} \ - -borderwidth {2} \ - -relief {raised} - - # build widget .top0.frame6.button8 - button .top0.frame6.button8 \ - -activebackground {#eed5b7} \ - -activeforeground {CornSilk2} \ - -background {Cornsilk2} \ - -command {lite counter a} \ - -disabledforeground {#b0b0b0} \ - -font {8x16} \ - -kanjifont {kanji16} \ - -text {Counter Example} - - # build widget .top0.frame6.button10 - button .top0.frame6.button10 \ - -activebackground {#eed5b7} \ - -activeforeground {CornSilk2} \ - -background {Cornsilk2} \ - -command {lite execute a} \ - -disabledforeground {#b0b0b0} \ - -font {8x16} \ - -kanjifont {kanji16} \ - -text {Execute} - - # build widget .top0.frame6.button9 - button .top0.frame6.button9 \ - -activebackground {#eed5b7} \ - -activeforeground {CornSilk2} \ - -background {Cornsilk2} \ - -command {canvaswh .top0.frame0.canvas2 1.6} \ - -disabledforeground {#b0b0b0} \ - -font {8x16} \ - -kanjifont {kanji16} \ - -text {Enlarge} - - # build widget .top0.frame6.button11 - button .top0.frame6.button11 \ - -activebackground {#eed5b7} \ - -activeforeground {CornSilk2} \ - -background {Cornsilk2} \ - -command {canvaswh .top0.frame0.canvas2 0.625} \ - -disabledforeground {#b0b0b0} \ - -font {8x16} \ - -kanjifont {kanji16} \ - -text { Shrink} - - # pack widget .top0.frame6 - pack append .top0.frame6 \ - .top0.frame6.button8 {right frame center fillx} \ - .top0.frame6.button10 {right frame center expand fillx} \ - .top0.frame6.button9 {left frame center} \ - .top0.frame6.button11 {left frame center} - - # pack widget .top0 - pack append .top0 \ - .top0.frame0 {bottom frame center expand fill} \ - .top0.frame1 {bottom frame center fill} \ - .top0.frame6 {top frame center fillx} - - # build canvas items .top0.frame0.canvas2 - set xfTmpTag [.top0.frame0.canvas2 create window -2480.03 -2615.93] - .top0.frame0.canvas2 itemconfigure $xfTmpTag \ - -anchor {nw} - set xfTmpTag [.top0.frame0.canvas2 create line 326 189 326 199] - .top0.frame0.canvas2 itemconfigure $xfTmpTag \ - -tags {cursol} - set xfTmpTag [.top0.frame0.canvas2 create line 321 194 331 194] - .top0.frame0.canvas2 itemconfigure $xfTmpTag \ - -tags {cursol} - - - - if {"[info procs XFEdit]" != ""} { - catch "XFMiscBindWidgetTree .top0" - after 2 "catch {XFEditSetShowWindows}" - } -} - -proc DestroyWindow.top0 {} {# xf ignore me 7 - if {"[info procs XFEdit]" != ""} { - if {"[info commands .top0]" != ""} { - global xfShowWindow.top0 - set xfShowWindow.top0 0 - XFEditSetPath . - after 2 "XFSaveAsProc .top0; XFEditSetShowWindows" - } - } { - catch "destroy .top0" - update - } -} - - -# procedure to show window . -proc ShowWindow. {args} {# xf ignore me 7 - - # Window manager configurations - global tkVersion - wm positionfrom . user - wm sizefrom . user - wm maxsize . 1280 1024 - wm title . {Lite} - - - # build widget .frame - frame .frame \ - -background {Cornsilk2} \ - -relief {raised} - - # build widget .frame.frame0 - frame .frame.frame0 \ - -background {Cornsilk2} \ - -borderwidth {2} \ - -relief {raised} - - # build widget .frame.frame0.label4 - label .frame.frame0.label4 \ - -background {Cornsilk2} \ - -font {8x16} \ - -kanjifont {kanji16} \ - -padx {2} \ - -relief {raised} \ - -text {ITL Formula:} - - # build widget .frame.frame0.button3 - button .frame.frame0.button3 \ - -activebackground {#eed5b7} \ - -activeforeground {CornSilk2} \ - -background {Cornsilk2} \ - -command {text_clear .frame.frame4.text0} \ - -disabledforeground {#b0b0b0} \ - -font {8x16} \ - -kanjifont {*-fixed-*-normal--16-*-jisx0208.1983-*} \ - -text {clear} - - # build widget .frame.frame0.menubutton0 - menubutton .frame.frame0.menubutton0 \ - -activeforeground {CornSilk2} \ - -background {Cornsilk2} \ - -font {8x16} \ - -kanjifont {*-fixed-*-normal--16-*-jisx0208.1983-*} \ - -menu {.frame.frame0.menubutton0.m} \ - -text {file} - # bindings - bind .frame.frame0.menubutton0 <Button-1> {MenuPopupPost .frame.frame0.menubutton0.m %X %Y} - bind .frame.frame0.menubutton0 <ButtonRelease-1> {MenuPopupRelease .frame.frame0.menubutton0.m %W} - - # build widget .frame.frame0.menubutton0.m - menu .frame.frame0.menubutton0.m \ - -activeforeground {CornSilk2} \ - -background {Cornsilk2} \ - -font {8x16} \ - -kanjifont {*-fixed-*-normal--16-*-jisx0208.1983-*} - .frame.frame0.menubutton0.m add command \ - -command {filehandling .frame.frame4.text0 load [FSBox "load"]} \ - -label {load} - .frame.frame0.menubutton0.m add command \ - -command {filehandling .frame.frame4.text0 save [FSBox "save"]} \ - -label {save} - .frame.frame0.menubutton0.m add command \ - -command {TokioCommand} \ - -label {Tokio} - .frame.frame0.menubutton0.m add command \ - -command {PrologCommand} \ - -label {Prolog} - # bindings - bind .frame.frame0.menubutton0.m <Any-ButtonRelease-1> {MenuPopupRelease .frame.frame0.menubutton0.m %W} - bind .frame.frame0.menubutton0.m <Shift-Button-1> {MenuPopupPost .frame.frame0.menubutton0.m %X %Y} - - # pack widget .frame.frame0 - pack append .frame.frame0 \ - .frame.frame0.label4 {left frame center expand fillx} \ - .frame.frame0.button3 {right frame center} \ - .frame.frame0.menubutton0 {left frame center fillx} - - # build widget .frame.frame4 - frame .frame.frame4 \ - -background {Cornsilk2} \ - -borderwidth {2} \ - -relief {raised} - - # build widget .frame.frame4.scrollbar1 - scrollbar .frame.frame4.scrollbar1 \ - -activeforeground {CornSilk2} \ - -background {Cornsilk2} \ - -command {.frame.frame4.text0 yview} \ - -foreground {#ffe4c4} - - # build widget .frame.frame4.text0 - text .frame.frame4.text0 \ - -background {Cornsilk2} \ - -font {8x16} \ - -kanjifont {kanji16} \ - -height {10} \ - -selectbackground {#b2dfee} \ - -selectborderwidth {1} \ - -selectforeground {CornSilk2} \ - -width {61} \ - -yscrollcommand {.frame.frame4.scrollbar1 set} - # bindings - bind .frame.frame4.text0 <Button-2> {%W mark set insert @%x,%y - %W insert insert [selection get] - %W yview -pickplace insert} - bind .frame.frame4.text0 <Button-3> {%W mark set anchor insert - %W tag add sel insert @%x,%y} - bind .frame.frame4.text0 <Control-Key-a> {%W mark set insert {insert linestart}} - bind .frame.frame4.text0 <Control-Key-b> {%W mark set insert {insert -1char}} - bind .frame.frame4.text0 <Control-Key-d> {%W delete insert} - bind .frame.frame4.text0 <Control-Key-e> {%W mark set insert {insert lineend}} - bind .frame.frame4.text0 <Control-Key-f> {%W mark set insert {insert +1char}} - bind .frame.frame4.text0 <Control-Key-k> {if ![string compare [%W get insert] "\n"] { - %W delete insert} else { - %W delete insert {insert lineend} - }} - bind .frame.frame4.text0 <Control-Key-n> {%W mark set insert {insert +1line}} - bind .frame.frame4.text0 <Control-Key-p> {%W mark set insert {insert -1line}} - bind .frame.frame4.text0 <Control-Key-w> {if [llength [%W tag ranges sel]] { - %W delete sel.first sel.last - }} - - # pack widget .frame.frame4 - pack append .frame.frame4 \ - .frame.frame4.text0 {left frame center expand fill} \ - .frame.frame4.scrollbar1 {right frame center filly} - - # pack widget .frame - pack append .frame \ - .frame.frame0 {top frame center fillx} \ - .frame.frame4 {left frame center expand fill} - - # build widget .frame3 - frame .frame3 \ - -background {Cornsilk2} \ - -borderwidth {2} \ - -relief {raised} - - # build widget .frame3.button4 - button .frame3.button4 \ - -activebackground {#eed5b7} \ - -activeforeground {CornSilk2} \ - -background {Cornsilk2} \ - -command {lite quit 0 -destroy .} \ - -disabledforeground {#b0b0b0} \ - -font {8x16} \ - -kanjifont {kanji16} \ - -text {Quit} - - # build widget .frame3.checkbutton5 - checkbutton .frame3.checkbutton5 \ - -activebackground {#eed5b7} \ - -activeforeground {CornSilk2} \ - -background {Cornsilk2} \ - -command {lite verbose "$verbose"} \ - -disabledforeground {#b0b0b0} \ - -font {8x16} \ - -kanjifont {kanji16} \ - -selector {#b03060} \ - -text {verbose} \ - -variable {verbose} - - # build widget .frame3.button7 - button .frame3.button7 \ - -activebackground {#eed5b7} \ - -activeforeground {CornSilk2} \ - -background {Cornsilk2} \ - -command {lite verify "{[$symbolicName(entry) get 0.0 end]}"} \ - -disabledforeground {#b0b0b0} \ - -font {8x16} \ - -kanjifont {kanji16} \ - -text {Verify} - - # pack widget .frame3 - pack append .frame3 \ - .frame3.button4 {left frame center} \ - .frame3.checkbutton5 {right frame center} \ - .frame3.button7 {top frame n fillx} - - # pack widget . - pack append . \ - .frame {top frame center expand fill} \ - .frame3 {top frame center fill} - - .frame.frame4.text0 insert end {} - - - - if {"[info procs XFEdit]" != ""} { - catch "XFMiscBindWidgetTree ." - after 2 "catch {XFEditSetShowWindows}" - } -} - - -# User defined procedures - - -# Procedure: FSBox -proc FSBox { {fsBoxMessage "Select file:"} {fsBoxFileName ""} {fsBoxActionOk ""} {fsBoxActionCancel ""}} { -# xf ignore me 5 -########## -# Procedure: FSBox -# Description: show file selector box -# Arguments: fsBoxMessage - the text to display -# fsBoxFileName - a file name that should be selected -# fsBoxActionOk - the action that should be performed on ok -# fsBoxActionCancel - the action that should be performed on cancel -# Returns: the filename that was selected, or nothing -# Sideeffects: none -########## -# -# global fsBox(activeBackground) - active background color -# global fsBox(activeForeground) - active foreground color -# global fsBox(background) - background color -# global fsBox(font) - text font -# global fsBox(foreground) - foreground color -# global fsBox(extensions) - scan directory for extensions -# global fsBox(scrollActiveForeground) - scrollbar active background color -# global fsBox(scrollBackground) - scrollbar background color -# global fsBox(scrollForeground) - scrollbar foreground color -# global fsBox(scrollSide) - side where scrollbar is located - - global fsBox - - set tmpButtonOpt "" - set tmpFrameOpt "" - set tmpMessageOpt "" - set tmpScaleOpt "" - set tmpScrollOpt "" - if {"$fsBox(activeBackground)" != ""} { - append tmpButtonOpt "-activebackground \"$fsBox(activeBackground)\" " - } - if {"$fsBox(activeForeground)" != ""} { - append tmpButtonOpt "-activeforeground \"$fsBox(activeForeground)\" " - } - if {"$fsBox(background)" != ""} { - append tmpButtonOpt "-background \"$fsBox(background)\" " - append tmpFrameOpt "-background \"$fsBox(background)\" " - append tmpMessageOpt "-background \"$fsBox(background)\" " - } - if {"$fsBox(font)" != ""} { - append tmpButtonOpt "-font \"$fsBox(font)\" " - append tmpMessageOpt "-font \"$fsBox(font)\" " - } - if {"$fsBox(foreground)" != ""} { - append tmpButtonOpt "-foreground \"$fsBox(foreground)\" " - append tmpMessageOpt "-foreground \"$fsBox(foreground)\" " - } - if {"$fsBox(scrollActiveForeground)" != ""} { - append tmpScrollOpt "-activeforeground \"$fsBox(scrollActiveForeground)\" " - } - if {"$fsBox(scrollBackground)" != ""} { - append tmpScrollOpt "-background \"$fsBox(scrollBackground)\" " - } - if {"$fsBox(scrollForeground)" != ""} { - append tmpScrollOpt "-foreground \"$fsBox(scrollForeground)\" " - } - - if {[file exists [file tail $fsBoxFileName]] && - [IsAFile [file tail $fsBoxFileName]]} { - set fsBox(name) [file tail $fsBoxFileName] - } { - set fsBox(name) "" - } - if {[file exists $fsBoxFileName] && [IsADir $fsBoxFileName]} { - set fsBox(path) $fsBoxFileName - } { - if {"[file rootname $fsBoxFileName]" != "."} { - set fsBox(path) [file rootname $fsBoxFileName] - } - } - if {$fsBox(showPixmap)} { - set fsBox(path) [string trimleft $fsBox(path) @] - } - if {"$fsBox(path)" != "" && [file exists $fsBox(path)] && - [IsADir $fsBox(path)]} { - set fsBox(internalPath) $fsBox(path) - } { - if {"$fsBox(internalPath)" == "" || - ![file exists $fsBox(internalPath)]} { - set fsBox(internalPath) [pwd] - } - } - # build widget structure - - # start build of toplevel - if {"[info commands XFDestroy]" != ""} { - catch {XFDestroy .fsBox} - } { - catch {destroy .fsBox} - } - toplevel .fsBox -borderwidth 0 - catch ".fsBox config $tmpFrameOpt" - wm geometry .fsBox 350x300 - wm title .fsBox {File select box} - wm maxsize .fsBox 1000 1000 - wm minsize .fsBox 100 100 - # end build of toplevel - - label .fsBox.message1 -anchor c -relief raised -text "$fsBoxMessage" - catch ".fsBox.message1 config $tmpMessageOpt" - - frame .fsBox.frame1 -borderwidth 0 -relief raised - catch ".fsBox.frame1 config $tmpFrameOpt" - - button .fsBox.frame1.ok -text "OK" -command " - global fsBox - set fsBox(name) \[.fsBox.file.file get\] - if {$fsBox(showPixmap)} { - set fsBox(path) @\[.fsBox.path.path get\] - } { - set fsBox(path) \[.fsBox.path.path get\] - } - set fsBox(internalPath) \[.fsBox.path.path get\] - $fsBoxActionOk - if {\"\[info commands XFDestroy\]\" != \"\"} { - catch {XFDestroy .fsBox} - } { - catch {destroy .fsBox} - }" - catch ".fsBox.frame1.ok config $tmpButtonOpt" - - button .fsBox.frame1.rescan -text "Rescan" -command { - global fsBox - FSBoxFSShow [.fsBox.path.path get] [.fsBox.pattern.pattern get] $fsBox(all)} - catch ".fsBox.frame1.rescan config $tmpButtonOpt" - - button .fsBox.frame1.cancel -text "Cancel" -command " - global fsBox - set fsBox(name) {} - set fsBox(path) {} - $fsBoxActionCancel - if {\"\[info commands XFDestroy\]\" != \"\"} { - catch {XFDestroy .fsBox} - } { - catch {destroy .fsBox} - }" - catch ".fsBox.frame1.cancel config $tmpButtonOpt" - - if {$fsBox(showPixmap)} { - frame .fsBox.frame2 -borderwidth 0 -relief raised - catch ".fsBox.frame2 config $tmpFrameOpt" - - scrollbar .fsBox.frame2.scrollbar3 -command {.fsBox.frame2.canvas2 xview} -orient {horizontal} -relief {raised} - catch ".fsBox.frame2.scrollbar3 config $tmpScrollOpt" - - scrollbar .fsBox.frame2.scrollbar1 -command {.fsBox.frame2.canvas2 yview} -relief {raised} - catch ".fsBox.frame2.scrollbar1 config $tmpScrollOpt" - - 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} - catch ".fsBox.frame2.canvas2 config $tmpFrameOpt" - - .fsBox.frame2.canvas2 addtag currentBitmap withtag [.fsBox.frame2.canvas2 create bitmap 5 5 -anchor nw] - } - - frame .fsBox.path -borderwidth 0 -relief raised - catch ".fsBox.path config $tmpFrameOpt" - - frame .fsBox.path.paths -borderwidth 2 -relief raised - catch ".fsBox.path.paths config $tmpFrameOpt" - - menubutton .fsBox.path.paths.paths -borderwidth 0 -menu ".fsBox.path.paths.paths.menu" -relief flat -text "Pathname:" - catch ".fsBox.path.paths.paths config $tmpButtonOpt" - - menu .fsBox.path.paths.paths.menu - catch ".fsBox.path.paths.paths.menu config $tmpButtonOpt" - - .fsBox.path.paths.paths.menu add command -label "[string trimright $fsBox(internalPath) {/@}]" -command " - global fsBox - FSBoxFSShow \[.fsBox.path.path get\] \[.fsBox.pattern.pattern get\] \$fsBox(all) - .fsBox.path.path delete 0 end - .fsBox.path.path insert 0 [string trimright $fsBox(internalPath) {/@}]" - - entry .fsBox.path.path -relief raised - catch ".fsBox.path.path config $tmpMessageOpt" - - if {![IsADir $fsBox(internalPath)]} { - set $fsBox(internalPath) [pwd] - } - .fsBox.path.path insert 0 $fsBox(internalPath) - - frame .fsBox.pattern -borderwidth 0 -relief raised - catch ".fsBox.pattern config $tmpFrameOpt" - - frame .fsBox.pattern.patterns -borderwidth 2 -relief raised - catch ".fsBox.pattern.patterns config $tmpFrameOpt" - - menubutton .fsBox.pattern.patterns.patterns -borderwidth 0 -menu ".fsBox.pattern.patterns.patterns.menu" -relief flat -text "Selection pattern:" - catch ".fsBox.pattern.patterns.patterns config $tmpButtonOpt" - - menu .fsBox.pattern.patterns.patterns.menu - catch ".fsBox.pattern.patterns.patterns.menu config $tmpButtonOpt" - - .fsBox.pattern.patterns.patterns.menu add checkbutton -label "Scan extensions" -variable fsBox(extensions) -command { - global fsBox - FSBoxFSShow [.fsBox.path.path get] [.fsBox.pattern.pattern get] $fsBox(all)} - - entry .fsBox.pattern.pattern -relief raised - catch ".fsBox.pattern.pattern config $tmpMessageOpt" - - .fsBox.pattern.pattern insert 0 $fsBox(pattern) - - frame .fsBox.files -borderwidth 0 -relief raised - catch ".fsBox.files config $tmpFrameOpt" - - scrollbar .fsBox.files.vscroll -relief raised -command ".fsBox.files.files yview" - catch ".fsBox.files.vscroll config $tmpScrollOpt" - - scrollbar .fsBox.files.hscroll -orient horiz -relief raised -command ".fsBox.files.files xview" - catch ".fsBox.files.hscroll config $tmpScrollOpt" - - listbox .fsBox.files.files -exportselection false -relief raised -xscrollcommand ".fsBox.files.hscroll set" -yscrollcommand ".fsBox.files.vscroll set" - catch ".fsBox.files.files config $tmpMessageOpt" - - frame .fsBox.file -borderwidth 0 -relief raised - catch ".fsBox.file config $tmpFrameOpt" - - label .fsBox.file.labelfile -relief raised -text "Filename:" - catch ".fsBox.file.labelfile config $tmpMessageOpt" - - entry .fsBox.file.file -relief raised - catch ".fsBox.file.file config $tmpMessageOpt" - - .fsBox.file.file delete 0 end - .fsBox.file.file insert 0 $fsBox(name) - - checkbutton .fsBox.pattern.all -offvalue 0 -onvalue 1 -text "Show all files" -variable fsBox(all) -command { - global fsBox - FSBoxFSShow [.fsBox.path.path get] [.fsBox.pattern.pattern get] $fsBox(all)} - catch ".fsBox.pattern.all config $tmpButtonOpt" - - FSBoxFSShow $fsBox(internalPath) $fsBox(pattern) $fsBox(all) - - # bindings - bind .fsBox.files.files <Double-Button-1> " - FSBoxFSFileSelectDouble %W $fsBox(showPixmap) \{$fsBoxActionOk\} %y" - bind .fsBox.files.files <ButtonPress-1> " - FSBoxFSFileSelect %W $fsBox(showPixmap) %y" - bind .fsBox.files.files <Button1-Motion> " - FSBoxFSFileSelect %W $fsBox(showPixmap) %y" - bind .fsBox.files.files <Shift-Button1-Motion> " - FSBoxFSFileSelect %W $fsBox(showPixmap) %y" - bind .fsBox.files.files <Shift-ButtonPress-1> " - FSBoxFSFileSelect %W $fsBox(showPixmap) %y" - - bind .fsBox.path.path <Tab> { - FSBoxFSNameComplete path} - bind .fsBox.path.path <Return> { - global tkVersion - global fsBox - FSBoxFSShow [.fsBox.path.path get] [.fsBox.pattern.pattern get] $fsBox(all) - FSBoxFSInsertPath - if {$tkVersion >= 3.0} { - .fsBox.file.file icursor end - } { - .fsBox.file.file cursor end - } - focus .fsBox.file.file} - catch "bind .fsBox.path.path <Up> {}" - bind .fsBox.path.path <Down> { - global tkVersion - if {$tkVersion >= 3.0} { - .fsBox.file.file icursor end - } { - .fsBox.file.file cursor end - } - focus .fsBox.file.file} - - bind .fsBox.file.file <Tab> { - FSBoxFSNameComplete file} - bind .fsBox.file.file <Return> " - global fsBox - set fsBox(name) \[.fsBox.file.file get\] - if {$fsBox(showPixmap)} { - set fsBox(path) @\[.fsBox.path.path get\] - } { - set fsBox(path) \[.fsBox.path.path get\] - } - set fsBox(internalPath) \[.fsBox.path.path get\] - $fsBoxActionOk - if {\"\[info commands XFDestroy\]\" != \"\"} { - catch {XFDestroy .fsBox} - } { - catch {destroy .fsBox} - }" - bind .fsBox.file.file <Up> { - global tkVersion - if {$tkVersion >= 3.0} { - .fsBox.path.path icursor end - } { - .fsBox.path.path cursor end - } - focus .fsBox.path.path} - bind .fsBox.file.file <Down> { - global tkVersion - if {$tkVersion >= 3.0} { - .fsBox.pattern.pattern icursor end - } { - .fsBox.pattern.pattern cursor end - } - focus .fsBox.pattern.pattern} - - bind .fsBox.pattern.pattern <Return> { - global fsBox - FSBoxFSShow [.fsBox.path.path get] [.fsBox.pattern.pattern get] $fsBox(all)} - bind .fsBox.pattern.pattern <Up> { - global tkVersion - if {$tkVersion >= 3.0} { - .fsBox.file.file icursor end - } { - .fsBox.file.file cursor end - } - focus .fsBox.file.file} - catch "bind .fsBox.pattern.pattern <Down> {}" - - # packing - pack append .fsBox.files .fsBox.files.vscroll "$fsBox(scrollSide) filly" .fsBox.files.hscroll {bottom fillx} .fsBox.files.files {left fill expand} - pack append .fsBox.file .fsBox.file.labelfile {left} .fsBox.file.file {left fill expand} - pack append .fsBox.frame1 .fsBox.frame1.ok {left fill expand} .fsBox.frame1.rescan {left fill expand} .fsBox.frame1.cancel {left fill expand} - pack append .fsBox.path.paths .fsBox.path.paths.paths {left} - pack append .fsBox.pattern.patterns .fsBox.pattern.patterns.patterns {left} - pack append .fsBox.path .fsBox.path.paths {left} .fsBox.path.path {left fill expand} - pack append .fsBox.pattern .fsBox.pattern.patterns {left} .fsBox.pattern.all {right fill} .fsBox.pattern.pattern {left fill expand} - if {$fsBox(showPixmap)} { - pack append .fsBox.frame2 .fsBox.frame2.scrollbar1 {left filly} .fsBox.frame2.canvas2 {top expand fill} .fsBox.frame2.scrollbar3 {top fillx} - - 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} - } { - 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} - } - - if {"$fsBoxActionOk" == "" && "$fsBoxActionCancel" == ""} { - # wait for the box to be destroyed - update idletask - grab .fsBox - tkwait window .fsBox - - if {"[string trim $fsBox(path)]" != "" || - "[string trim $fsBox(name)]" != ""} { - if {"[string trimleft [string trim $fsBox(name)] /]" == ""} { - return [string trimright [string trim $fsBox(path)] /] - } { - return [string trimright [string trim $fsBox(path)] /]/[string trimleft [string trim $fsBox(name)] /] - } - } - } -} - - -# Procedure: FSBoxBindSelectOne -proc FSBoxBindSelectOne { fsBoxW fsBoxY} { -# xf ignore me 6 - - set fsBoxNearest [$fsBoxW nearest $fsBoxY] - if {$fsBoxNearest >= 0} { - $fsBoxW select from $fsBoxNearest - $fsBoxW select to $fsBoxNearest - } -} - - -# Procedure: FSBoxFSFileSelect -proc FSBoxFSFileSelect { fsBoxW fsBoxShowPixmap fsBoxY} { -# xf ignore me 6 - global fsBox - - FSBoxBindSelectOne $fsBoxW $fsBoxY - set fsBoxNearest [$fsBoxW nearest $fsBoxY] - if {$fsBoxNearest >= 0} { - set fsBoxTmpEntry [$fsBoxW get $fsBoxNearest] - if {"[string index $fsBoxTmpEntry [expr [string length $fsBoxTmpEntry]-1]]" == "/" || - "[string index $fsBoxTmpEntry [expr [string length $fsBoxTmpEntry]-1]]" == "@"} { - set fsBoxFileName [string range $fsBoxTmpEntry 0 [expr [string length $fsBoxTmpEntry]-2]] - if {![IsADir [string trimright $fsBox(internalPath)/$fsBoxFileName @]] && - ![IsASymlink [string trimright $fsBox(internalPath)/$fsBoxFileName @]]} { - set fsBoxFileName $fsBoxTmpEntry - } - } { - if {"[string index $fsBoxTmpEntry [expr [string length $fsBoxTmpEntry]-1]]" == "*"} { - set fsBoxFileName [string range $fsBoxTmpEntry 0 [expr [string length $fsBoxTmpEntry]-2]] - if {![file executable $fsBox(internalPath)/$fsBoxFileName]} { - set fsBoxFileName $fsBoxTmpEntry - } - } { - set fsBoxFileName $fsBoxTmpEntry - } - } - if {![IsADir [string trimright $fsBox(internalPath)/$fsBoxFileName @]]} { - set fsBox(name) $fsBoxFileName - .fsBox.file.file delete 0 end - .fsBox.file.file insert 0 $fsBox(name) - if {$fsBoxShowPixmap} { - catch ".fsBox.frame2.canvas2 itemconfigure currentBitmap -bitmap \"@$fsBox(internalPath)/$fsBox(name)\"" - } - } - } -} - - -# Procedure: FSBoxFSFileSelectDouble -proc FSBoxFSFileSelectDouble { fsBoxW fsBoxShowPixmap fsBoxAction fsBoxY} { -# xf ignore me 6 - global fsBox - - FSBoxBindSelectOne $fsBoxW $fsBoxY - set fsBoxNearest [$fsBoxW nearest $fsBoxY] - if {$fsBoxNearest >= 0} { - set fsBoxTmpEntry [$fsBoxW get $fsBoxNearest] - if {"$fsBoxTmpEntry" == "../"} { - set fsBoxTmpEntry [string trimright [string trim $fsBox(internalPath)] "@/"] - if {"$fsBoxTmpEntry" == ""} { - return - } - FSBoxFSShow [file dirname $fsBoxTmpEntry] [.fsBox.pattern.pattern get] $fsBox(all) - .fsBox.path.path delete 0 end - .fsBox.path.path insert 0 $fsBox(internalPath) - } { - if {"[string index $fsBoxTmpEntry [expr [string length $fsBoxTmpEntry]-1]]" == "/" || - "[string index $fsBoxTmpEntry [expr [string length $fsBoxTmpEntry]-1]]" == "@"} { - set fsBoxFileName [string range $fsBoxTmpEntry 0 [expr [string length $fsBoxTmpEntry]-2]] - if {![IsADir [string trimright $fsBox(internalPath)/$fsBoxFileName @]] && - ![IsASymlink [string trimright $fsBox(internalPath)/$fsBoxFileName @]]} { - set fsBoxFileName $fsBoxTmpEntry - } - } { - if {"[string index $fsBoxTmpEntry [expr [string length $fsBoxTmpEntry]-1]]" == "*"} { - set fsBoxFileName [string range $fsBoxTmpEntry 0 [expr [string length $fsBoxTmpEntry]-2]] - if {![file executable $fsBox(internalPath)/$fsBoxFileName]} { - set fsBoxFileName $fsBoxTmpEntry - } - } { - set fsBoxFileName $fsBoxTmpEntry - } - } - if {[IsADir [string trimright $fsBox(internalPath)/$fsBoxFileName @]]} { - set fsBox(internalPath) "[string trimright $fsBox(internalPath) {/@}]/$fsBoxFileName" - FSBoxFSShow $fsBox(internalPath) [.fsBox.pattern.pattern get] $fsBox(all) - .fsBox.path.path delete 0 end - .fsBox.path.path insert 0 $fsBox(internalPath) - } { - set fsBox(name) $fsBoxFileName - if {$fsBoxShowPixmap} { - set fsBox(path) @$fsBox(internalPath) - } { - set fsBox(path) $fsBox(internalPath) - } - if {"$fsBoxAction" != ""} { - eval "global fsBox; $fsBoxAction" - } - if {"[info commands XFDestroy]" != ""} { - catch {XFDestroy .fsBox} - } { - catch {destroy .fsBox} - } - } - } - } -} - - -# Procedure: FSBoxFSInsertPath -proc FSBoxFSInsertPath {} { -# xf ignore me 6 - global fsBox - - set fsBoxLast [.fsBox.path.paths.paths.menu index last] - set fsBoxNewEntry [string trimright [.fsBox.path.path get] "/@"] - for {set fsBoxCounter 0} {$fsBoxCounter <= $fsBoxLast} {incr fsBoxCounter 1} { - if {"$fsBoxNewEntry" == "[lindex [.fsBox.path.paths.paths.menu entryconfigure $fsBoxCounter -label] 4]"} { - return - } - } - if {$fsBoxLast < 9} { - .fsBox.path.paths.paths.menu add command -label "$fsBoxNewEntry" -command " - global fsBox - FSBoxFSShow $fsBoxNewEntry \[.fsBox.pattern.pattern get\] \$fsBox(all) - .fsBox.path.path delete 0 end - .fsBox.path.path insert 0 $fsBoxNewEntry" - } { - for {set fsBoxCounter 0} {$fsBoxCounter < $fsBoxLast} {incr fsBoxCounter 1} { - .fsBox.path.paths.paths.menu entryconfigure $fsBoxCounter -label [lindex [.fsBox.path.paths.paths.menu entryconfigure [expr $fsBoxCounter+1] -label] 4] - .fsBox.path.paths.paths.menu entryconfigure $fsBoxCounter -command " - global fsBox - FSBoxFSShow [lindex [.fsBox.path.paths.paths.menu entryconfigure [expr $fsBoxCounter+1] -label] 4] \[.fsBox.pattern.pattern get\] \$fsBox(all) - .fsBox.path.path delete 0 end - .fsBox.path.path insert 0 [lindex [.fsBox.path.paths.paths.menu entryconfigure [expr $fsBoxCounter+1] -label] 4]" - } - .fsBox.path.paths.paths.menu entryconfigure $fsBoxLast -label "$fsBoxNewEntry" - .fsBox.path.paths.paths.menu entryconfigure $fsBoxCounter -command " - global fsBox - FSBoxFSShow \[.fsBox.path.path get\] \[.fsBox.pattern.pattern get\] \$fsBox(all) - .fsBox.path.path delete 0 end - .fsBox.path.path insert 0 $fsBoxNewEntry" - } -} - - -# Procedure: FSBoxFSNameComplete -proc FSBoxFSNameComplete { fsBoxType} { -# xf ignore me 6 - global tkVersion - global fsBox - - set fsBoxNewFile "" - if {"$fsBoxType" == "path"} { - set fsBoxDirName [file dirname [.fsBox.path.path get]] - set fsBoxFileName [file tail [.fsBox.path.path get]] - } { - set fsBoxDirName [file dirname [.fsBox.path.path get]/] - set fsBoxFileName [file tail [.fsBox.file.file get]] - } - - set fsBoxNewFile "" - if {[IsADir [string trimright $fsBoxDirName @]]} { - catch "glob -nocomplain $fsBoxDirName/${fsBoxFileName}*" fsBoxResult - foreach fsBoxCounter $fsBoxResult { - if {"$fsBoxNewFile" == ""} { - set fsBoxNewFile [file tail $fsBoxCounter] - } { - if {"[string index [file tail $fsBoxCounter] 0]" != - "[string index $fsBoxNewFile 0]"} { - set fsBoxNewFile "" - break - } - set fsBoxCounter1 0 - set fsBoxTmpFile1 $fsBoxNewFile - set fsBoxTmpFile2 [file tail $fsBoxCounter] - set fsBoxLength1 [string length $fsBoxTmpFile1] - set fsBoxLength2 [string length $fsBoxTmpFile2] - set fsBoxNewFile "" - if {$fsBoxLength1 > $fsBoxLength2} { - set fsBoxLength1 $fsBoxLength2 - } - while {$fsBoxCounter1 < $fsBoxLength1} { - if {"[string index $fsBoxTmpFile1 $fsBoxCounter1]" == "[string index $fsBoxTmpFile2 $fsBoxCounter1]"} { - append fsBoxNewFile [string index $fsBoxTmpFile1 $fsBoxCounter1] - } { - break - } - incr fsBoxCounter1 1 - } - } - } - } - if {"$fsBoxNewFile" != ""} { - if {[IsADir [string trimright $fsBoxDirName/$fsBoxNewFile @]] || - ![IsAFile [string trimright $fsBoxDirName/$fsBoxNewFile @]]} { - if {[IsADir [string trimright $fsBoxDirName/$fsBoxNewFile @]]} { - if {"$fsBoxDirName" == "/"} { - .fsBox.path.path delete 0 end - .fsBox.path.path insert 0 "/[string trimright [string trim $fsBoxNewFile /] @]/" - } { - .fsBox.path.path delete 0 end - .fsBox.path.path insert 0 "[string trimright $fsBoxDirName /]/[string trimright [string trim $fsBoxNewFile /] @]/" - } - FSBoxFSShow [.fsBox.path.path get] [.fsBox.pattern.pattern get] $fsBox(all) - FSBoxFSInsertPath - } { - .fsBox.path.path delete 0 end - .fsBox.path.path insert 0 "[string trimright $fsBoxDirName /]/[string trimright [string trim $fsBoxNewFile /] @]" - } - } { - .fsBox.path.path delete 0 end - .fsBox.path.path insert 0 "[string trimright $fsBoxDirName {@/}]/" - .fsBox.file.file delete 0 end - .fsBox.file.file insert 0 $fsBoxNewFile - if {$tkVersion >= 3.0} { - .fsBox.file.file icursor end - } { - .fsBox.file.file cursor end - } - focus .fsBox.file.file - } - } -} - - -# Procedure: FSBoxFSShow -proc FSBoxFSShow { fsBoxPath fsBoxPattern fsBoxAll} { -# xf ignore me 6 - global fsBox - - set tmpButtonOpt "" - if {"$fsBox(activeBackground)" != ""} { - append tmpButtonOpt "-activebackground \"$fsBox(activeBackground)\" " - } - if {"$fsBox(activeForeground)" != ""} { - append tmpButtonOpt "-activeforeground \"$fsBox(activeForeground)\" " - } - if {"$fsBox(background)" != ""} { - append tmpButtonOpt "-background \"$fsBox(background)\" " - } - if {"$fsBox(font)" != ""} { - append tmpButtonOpt "-font \"$fsBox(font)\" " - } - if {"$fsBox(foreground)" != ""} { - append tmpButtonOpt "-foreground \"$fsBox(foreground)\" " - } - - set fsBox(pattern) $fsBoxPattern - if {[file exists $fsBoxPath] && [file readable $fsBoxPath] && - [IsADir $fsBoxPath]} { - set fsBox(internalPath) $fsBoxPath - } { - if {[file exists $fsBoxPath] && [file readable $fsBoxPath] && - [IsAFile $fsBoxPath]} { - set fsBox(internalPath) [file dirname $fsBoxPath] - .fsBox.file.file delete 0 end - .fsBox.file.file insert 0 [file tail $fsBoxPath] - set fsBoxPath $fsBox(internalPath) - } { - while {"$fsBoxPath" != "" && "$fsBoxPath" != "/" && - ![file isdirectory $fsBoxPath]} { - set fsBox(internalPath) [file dirname $fsBoxPath] - set fsBoxPath $fsBox(internalPath) - } - } - } - if {"$fsBoxPath" == ""} { - set fsBoxPath "/" - set fsBox(internalPath) "/" - } - .fsBox.path.path delete 0 end - .fsBox.path.path insert 0 $fsBox(internalPath) - - if {[.fsBox.files.files size] > 0} { - .fsBox.files.files delete 0 end - } - if {$fsBoxAll} { - if {[catch "exec ls -F -a $fsBoxPath" fsBoxResult]} { - puts stderr "$fsBoxResult" - } - } { - if {[catch "exec ls -F $fsBoxPath" fsBoxResult]} { - puts stderr "$fsBoxResult" - } - } - set fsBoxElementList [lsort $fsBoxResult] - - foreach fsBoxCounter [winfo children .fsBox.pattern.patterns.patterns] { - if {[string length [info commands XFDestroy]] > 0} { - catch {XFDestroy $fsBoxCounter} - } { - catch {destroy $fsBoxCounter} - } - } - menu .fsBox.pattern.patterns.patterns.menu - catch ".fsBox.pattern.patterns.patterns.menu config $tmpButtonOpt" - - if {$fsBox(extensions)} { - .fsBox.pattern.patterns.patterns.menu add command -label "*" -command { - global fsBox - set fsBox(pattern) "*" - .fsBox.pattern.pattern delete 0 end - .fsBox.pattern.pattern insert 0 $fsBox(pattern) - FSBoxFSShow [.fsBox.path.path get] $fsBox(pattern) $fsBox(all)} - } - - if {"$fsBoxPath" != "/"} { - .fsBox.files.files insert end "../" - } - foreach fsBoxCounter $fsBoxElementList { - if {[string match $fsBoxPattern $fsBoxCounter] || - [IsADir [string trimright $fsBoxPath/$fsBoxCounter "/@"]]} { - if {"$fsBoxCounter" != "../" && - "$fsBoxCounter" != "./"} { - .fsBox.files.files insert end $fsBoxCounter - } - } - - if {$fsBox(extensions)} { - catch "file rootname $fsBoxCounter" fsBoxRootName - catch "file extension $fsBoxCounter" fsBoxExtension - set fsBoxExtension [string trimright $fsBoxExtension "/*@"] - if {"$fsBoxExtension" != "" && "$fsBoxRootName" != ""} { - set fsBoxInsert 1 - set fsBoxLast [.fsBox.pattern.patterns.patterns.menu index last] - for {set fsBoxCounter1 0} {$fsBoxCounter1 <= $fsBoxLast} {incr fsBoxCounter1 1} { - if {"*$fsBoxExtension" == "[lindex [.fsBox.pattern.patterns.patterns.menu entryconfigure $fsBoxCounter1 -label] 4]"} { - set fsBoxInsert 0 - } - } - if {$fsBoxInsert} { - .fsBox.pattern.patterns.patterns.menu add command -label "*$fsBoxExtension" -command " - global fsBox - set fsBox(pattern) \"*$fsBoxExtension\" - .fsBox.pattern.pattern delete 0 end - .fsBox.pattern.pattern insert 0 \$fsBox(pattern) - FSBoxFSShow \[.fsBox.path.path get\] \$fsBox(pattern) \$fsBox(all)" - } - } - } - } - if {$fsBox(extensions)} { - .fsBox.pattern.patterns.patterns.menu add separator - } - if {$fsBox(extensions) || - "[.fsBox.pattern.patterns.patterns.menu index last]" == "none"} { - .fsBox.pattern.patterns.patterns.menu add checkbutton -label "Scan extensions" -variable "fsBox(extensions)" -command { - global fsBox - FSBoxFSShow [.fsBox.path.path get] [.fsBox.pattern.pattern get] $fsBox(all)} - } -} - - -# Procedure: InputBoxInternal -proc InputBoxInternal { inputBoxMessage inputBoxCommandOk inputBoxCommandCancel inputBoxGeometry inputBoxTitle lineNum} { -# xf ignore me 6 - global inputBox - - set tmpButtonOpt "" - set tmpFrameOpt "" - set tmpMessageOpt "" - set tmpScaleOpt "" - set tmpScrollOpt "" - if {"$inputBox(activeBackground)" != ""} { - append tmpButtonOpt "-activebackground \"$inputBox(activeBackground)\" " - } - if {"$inputBox(activeForeground)" != ""} { - append tmpButtonOpt "-activeforeground \"$inputBox(activeForeground)\" " - } - if {"$inputBox(background)" != ""} { - append tmpButtonOpt "-background \"$inputBox(background)\" " - append tmpFrameOpt "-background \"$inputBox(background)\" " - append tmpMessageOpt "-background \"$inputBox(background)\" " - } - if {"$inputBox(font)" != ""} { - append tmpButtonOpt "-font \"$inputBox(font)\" " - append tmpMessageOpt "-font \"$inputBox(font)\" " - } - if {"$inputBox(foreground)" != ""} { - append tmpButtonOpt "-foreground \"$inputBox(foreground)\" " - append tmpMessageOpt "-foreground \"$inputBox(foreground)\" " - } - if {"$inputBox(scrollActiveForeground)" != ""} { - append tmpScrollOpt "-activeforeground \"$inputBox(scrollActiveForeground)\" " - } - if {"$inputBox(scrollBackground)" != ""} { - append tmpScrollOpt "-background \"$inputBox(scrollBackground)\" " - } - if {"$inputBox(scrollForeground)" != ""} { - append tmpScrollOpt "-foreground \"$inputBox(scrollForeground)\" " - } - - # start build of toplevel - if {"[info commands XFDestroy]" != ""} { - catch {XFDestroy $inputBox(toplevelName)} - } { - catch {destroy $inputBox(toplevelName)} - } - toplevel $inputBox(toplevelName) -borderwidth 0 - catch "$inputBox(toplevelName) config $tmpFrameOpt" - if {[catch "wm geometry $inputBox(toplevelName) $inputBoxGeometry"]} { - wm geometry $inputBox(toplevelName) 350x150 - } - wm title $inputBox(toplevelName) $inputBoxTitle - wm maxsize $inputBox(toplevelName) 1000 1000 - wm minsize $inputBox(toplevelName) 100 100 - # end build of toplevel - - message $inputBox(toplevelName).message1 -anchor "$inputBox(anchor)" -justify "$inputBox(justify)" -relief raised -text "$inputBoxMessage" - catch "$inputBox(toplevelName).message1 config $tmpMessageOpt" - - set xfTmpWidth [string range $inputBoxGeometry 0 [expr [string first x $inputBoxGeometry]-1]] - if {"$xfTmpWidth" != ""} { - # set message size - catch "$inputBox(toplevelName).message1 configure -width [expr $xfTmpWidth-10]" - } { - $inputBox(toplevelName).message1 configure -aspect 1500 - } - - frame $inputBox(toplevelName).frame0 -borderwidth 0 -relief raised - catch "$inputBox(toplevelName).frame0 config $tmpFrameOpt" - - frame $inputBox(toplevelName).frame1 -borderwidth 0 -relief raised - catch "$inputBox(toplevelName).frame1 config $tmpFrameOpt" - - if {$lineNum == 1} { - scrollbar $inputBox(toplevelName).frame1.hscroll -orient "horizontal" -relief raised -command "$inputBox(toplevelName).frame1.input view" - catch "$inputBox(toplevelName).frame1.hscroll config $tmpScrollOpt" - - entry $inputBox(toplevelName).frame1.input -relief raised -scrollcommand "$inputBox(toplevelName).frame1.hscroll set" - catch "$inputBox(toplevelName).frame1.input config $tmpMessageOpt" - - $inputBox(toplevelName).frame1.input insert 0 $inputBox($inputBox(toplevelName),inputOne) - - # bindings - bind $inputBox(toplevelName).frame1.input <Return> " - global inputBox - set inputBox($inputBox(toplevelName),inputOne) \[$inputBox(toplevelName).frame1.input get\] - if {\"\[info commands XFDestroy\]\" != \"\"} { - catch {XFDestroy $inputBox(toplevelName)} - } { - catch {destroy $inputBox(toplevelName)} - } - $inputBoxCommandOk" - - # packing - pack append $inputBox(toplevelName).frame1 $inputBox(toplevelName).frame1.hscroll {bottom fill} $inputBox(toplevelName).frame1.input {top fill expand} - } { - text $inputBox(toplevelName).frame1.input -relief raised -wrap none -borderwidth 2 -yscrollcommand "$inputBox(toplevelName).frame1.vscroll set" - catch "$inputBox(toplevelName).frame1.input config $tmpMessageOpt" - - scrollbar $inputBox(toplevelName).frame1.vscroll -relief raised -command "$inputBox(toplevelName).frame1.input yview" - catch "$inputBox(toplevelName).frame1.vscroll config $tmpScrollOpt" - - $inputBox(toplevelName).frame1.input insert 1.0 $inputBox($inputBox(toplevelName),inputMulti) - - # bindings - bind $inputBox(toplevelName).frame1.input <Control-Return> " - global inputBox - set inputBox($inputBox(toplevelName),inputMulti) \[$inputBox(toplevelName).frame1.input get 1.0 end\] - if {\"\[info commands XFDestroy\]\" != \"\"} { - catch {XFDestroy $inputBox(toplevelName)} - } { - catch {destroy $inputBox(toplevelName)} - } - $inputBoxCommandOk" - bind $inputBox(toplevelName).frame1.input <Meta-Return> " - global inputBox - set inputBox($inputBox(toplevelName),inputMulti) \[$inputBox(toplevelName).frame1.input get 1.0 end\] - if {\"\[info commands XFDestroy\]\" != \"\"} { - catch {XFDestroy $inputBox(toplevelName)} - } { - catch {destroy $inputBox(toplevelName)} - } - $inputBoxCommandOk" - - # packing - pack append $inputBox(toplevelName).frame1 $inputBox(toplevelName).frame1.vscroll "$inputBox(scrollSide) filly" $inputBox(toplevelName).frame1.input {left fill expand} - } - - button $inputBox(toplevelName).frame0.button0 -text "OK" -command " - global inputBox - if {$lineNum == 1} { - set inputBox($inputBox(toplevelName),inputOne) \[$inputBox(toplevelName).frame1.input get\] - } { - set inputBox($inputBox(toplevelName),inputMulti) \[$inputBox(toplevelName).frame1.input get 1.0 end\] - } - if {\"\[info commands XFDestroy\]\" != \"\"} { - catch {XFDestroy $inputBox(toplevelName)} - } { - catch {destroy $inputBox(toplevelName)} - } - $inputBoxCommandOk" - catch "$inputBox(toplevelName).frame0.button0 config $tmpButtonOpt" - - button $inputBox(toplevelName).frame0.button1 -text "Cancel" -command " - global inputBox - if {$lineNum == 1} { - set inputBox($inputBox(toplevelName),inputOne) \"\" - } { - set inputBox($inputBox(toplevelName),inputMulti) \"\" - } - if {\"\[info commands XFDestroy\]\" != \"\"} { - catch {XFDestroy $inputBox(toplevelName)} - } { - catch {destroy $inputBox(toplevelName)} - } - $inputBoxCommandCancel" - catch "$inputBox(toplevelName).frame0.button1 config $tmpButtonOpt" - - pack append $inputBox(toplevelName).frame0 $inputBox(toplevelName).frame0.button0 {left fill expand} $inputBox(toplevelName).frame0.button1 {left fill expand} - - pack append $inputBox(toplevelName) $inputBox(toplevelName).frame0 {bottom fill} $inputBox(toplevelName).frame1 {bottom fill expand} $inputBox(toplevelName).message1 {top fill} -} - - -# Procedure: InputBoxMulti -proc InputBoxMulti { {inputBoxMessage "Input box:"} {inputBoxCommandOk ""} {inputBoxCommandCancel ""} {inputBoxGeometry "350x150"} {inputBoxTitle "Input box"}} { -# xf ignore me 5 -########## -# Procedure: InputBoxMulti -# Description: show input box with one text line -# Arguments: {inputBoxMessage} - message to display -# {inputBoxCommandOk} - the command to call after ok -# {inputBoxCommandCancel} - the command to call after cancel -# {inputBoxGeometry} - the geometry for the window -# {inputBoxTitle} - the title for the window -# Returns: The entered text -# Sideeffects: none -# Notes: there exist also a function called: -# InputBoxOne - to enter one line text -########## -# -# global inputBox(activeBackground) - active background color -# global inputBox(activeForeground) - active foreground color -# global inputBox(anchor) - anchor for message box -# global inputBox(background) - background color -# global inputBox(erase) - erase previous text -# global inputBox(font) - message font -# global inputBox(foreground) - foreground color -# global inputBox(justify) - justify for message box -# global inputBox(scrollActiveForeground) - scrollbar active background color -# global inputBox(scrollBackground) - scrollbar background color -# global inputBox(scrollForeground) - scrollbar foreground color -# global inputBox(scrollSide) - side where scrollbar is located -# global inputBox(toplevelName) - the toplevel name -# global inputBox(toplevelName,inputMulti) - the text in the text widget - - global inputBox - - if {"$inputBoxGeometry" == ""} { - set inputBoxGeometry 350x150 - } - if {$inputBox(erase)} { - set inputBox($inputBox(toplevelName),inputMulti) "" - } { - if {![info exists inputBox($inputBox(toplevelName),inputMulti)]} { - set inputBox($inputBox(toplevelName),inputMulti) "" - } - } - InputBoxInternal $inputBoxMessage $inputBoxCommandOk $inputBoxCommandCancel $inputBoxGeometry $inputBoxTitle 2 - - # wait for the box to be destroyed - update idletask - grab $inputBox(toplevelName) - tkwait window $inputBox(toplevelName) - - return $inputBox($inputBox(toplevelName),inputMulti) -} - - -# Procedure: InputBoxOne -proc InputBoxOne { {inputBoxMessage "Input box:"} {inputBoxCommandOk ""} {inputBoxCommandCancel ""} {inputBoxGeometry "350x150"} {inputBoxTitle "Input box"}} { -# xf ignore me 5 -########## -# Procedure: InputBoxOne -# Description: show input box with one text line -# Arguments: {inputBoxMessage} - message to display -# {inputBoxCommandOk} - the command to call after ok -# {inputBoxCommandCancel} - the command to call after cancel -# {inputBoxGeometry} - the geometry for the window -# {inputBoxTitle} - the title for the window -# Returns: The entered text -# Sideeffects: none -# Notes: there exist also a function called: -# InputBoxMulti - to enter multiline text -########## -# -# global inputBox(activeBackground) - active background color -# global inputBox(activeForeground) - active foreground color -# global inputBox(anchor) - anchor for message box -# global inputBox(background) - background color -# global inputBox(erase) - erase previous text -# global inputBox(font) - message font -# global inputBox(foreground) - foreground color -# global inputBox(justify) - justify for message box -# global inputBox(scrollActiveForeground) - scrollbar active background color -# global inputBox(scrollBackground) - scrollbar background color -# global inputBox(scrollForeground) - scrollbar foreground color -# global inputBox(scrollSide) - side where scrollbar is located -# global inputBox(toplevelName) - the toplevel name -# global inputBox(toplevelName,inputOne) - the text in the entry widget - - global inputBox - - if {$inputBox(erase)} { - set inputBox($inputBox(toplevelName),inputOne) "" - } { - if {![info exists inputBox($inputBox(toplevelName),inputOne)]} { - set inputBox($inputBox(toplevelName),inputOne) "" - } - } - InputBoxInternal $inputBoxMessage $inputBoxCommandOk $inputBoxCommandCancel $inputBoxGeometry $inputBoxTitle 1 - - # wait for the box to be destroyed - update idletask - grab $inputBox(toplevelName) - tkwait window $inputBox(toplevelName) - - return $inputBox($inputBox(toplevelName),inputOne) -} - - -# Procedure: IsADir -proc IsADir { pathName} { -# xf ignore me 5 -########## -# Procedure: IsADir -# Description: check if name is a directory (including symbolic links) -# Arguments: pathName - the path to check -# Returns: 1 if its a directory, otherwise 0 -# Sideeffects: none -########## - - if {[file isdirectory $pathName]} { - return 1 - } { - catch "file type $pathName" fileType - if {"$fileType" == "link"} { - if {[catch "file readlink $pathName" linkName]} { - return 0 - } - catch "file type $linkName" fileType - while {"$fileType" == "link"} { - if {[catch "file readlink $linkName" linkName]} { - return 0 - } - catch "file type $linkName" fileType - } - return [file isdirectory $linkName] - } - } - return 0 -} - - -# Procedure: IsAFile -proc IsAFile { fileName} { -# xf ignore me 5 -########## -# Procedure: IsAFile -# Description: check if filename is a file (including symbolic links) -# Arguments: fileName - the filename to check -# Returns: 1 if its a file, otherwise 0 -# Sideeffects: none -########## - - if {[file isfile $fileName]} { - return 1 - } { - catch "file type $fileName" fileType - if {"$fileType" == "link"} { - if {[catch "file readlink $fileName" linkName]} { - return 0 - } - catch "file type $linkName" fileType - while {"$fileType" == "link"} { - if {[catch "file readlink $linkName" linkName]} { - return 0 - } - catch "file type $linkName" fileType - } - return [file isfile $linkName] - } - } - return 0 -} - - -# Procedure: IsASymlink -proc IsASymlink { fileName} { -# xf ignore me 5 -########## -# Procedure: IsASymlink -# Description: check if filename is a symbolic link -# Arguments: fileName - the path/filename to check -# Returns: none -# Sideeffects: none -########## - - catch "file type $fileName" fileType - if {"$fileType" == "link"} { - return 1 - } - return 0 -} - - -# Procedure: PrologCommand -proc PrologCommand {} { -prolog {prolog_call [InputBoxOne "Prolog Command:"]} lite -} - - -# Procedure: TokioCommand -proc TokioCommand {} { -prolog {tokio_call [InputBoxOne "Tokio Command:"]} lite -} - - -# Procedure: canvaswh -proc canvaswh { c scale} { -global scalex scaley -if {! $scalex && ! $scaley } { - regexp {([0-9]+)x([0-9]+)} [wm geometry .] dm w h - set h [$c canvasy [expr $h/2]] - set w [$c canvasx [expr $w/2]] -} else { - set h $scaley - set w $scalex -} -$c scale all $w $h $scale $scale -} - - -# Procedure: crosshair -proc crosshair { c x y} { -global scalex scaley -if {[$c find withtag cursol] != {}} { - $c delete cursol -} -set cs 5 -set x [$c canvasx $x] -set y [$c canvasy $y] -$c create line $x [expr $y - $cs] $x [expr $y + $cs] -tags cursol -$c create line [expr $x - $cs] $y [expr $x + $cs] $y -tags cursol -set scalex $x -set scaley $y -} - - -# Procedure: event -proc event { args now} { -prolog "tokio_event $args $now" tokio -} - - -# Procedure: filehandling -proc filehandling { t mode file} { -if {[string compare $mode "load"] == 0} { - if [file isfile $file] { - $t delete 0.0 end - set F [open $file r] - while {[gets $F string] != -1} { - $t insert end "$string\n" - } - close $F - } -} else { - set line [$t get 0.0 end] -# if [file writable $dir] { - if [expr [llength $line] > 0] { - set F [open $file w] - puts $F $line - close $F - } -# } -} -} - - -# Procedure: lite -proc lite { a b} { -prolog "event $a $b" lite -} - - -# Procedure: text_clear -proc text_clear { t} { -$t delete 0.0 end -} - - -# Internal procedures - - -# Procedure: Alias -if {"[info procs Alias]" == ""} { -proc Alias { args} { -# xf ignore me 7 -########## -# Procedure: Alias -# Description: establish an alias for a procedure -# Arguments: args - no argument means that a list of all aliases -# is returned. Otherwise the first parameter is -# the alias name, and the second parameter is -# the procedure that is aliased. -# Returns: nothing, the command that is bound to the alias or a -# list of all aliases - command pairs. -# Sideeffects: internalAliasList is updated, and the alias -# proc is inserted -########## - global internalAliasList - - if {[llength $args] == 0} { - return $internalAliasList - } { - if {[llength $args] == 1} { - set xfTmpIndex [lsearch $internalAliasList "[lindex $args 0] *"] - if {$xfTmpIndex != -1} { - return [lindex [lindex $internalAliasList $xfTmpIndex] 1] - } - } { - if {[llength $args] == 2} { - eval "proc [lindex $args 0] {args} {#xf ignore me 4 -return \[eval \"[lindex $args 1] \$args\"\]}" - set xfTmpIndex [lsearch $internalAliasList "[lindex $args 0] *"] - if {$xfTmpIndex != -1} { - set internalAliasList [lreplace $internalAliasList $xfTmpIndex $xfTmpIndex "[lindex $args 0] [lindex $args 1]"] - } { - lappend internalAliasList "[lindex $args 0] [lindex $args 1]" - } - } { - error "Alias: wrong number or args: $args" - } - } - } -} -} - - -# Procedure: GetSelection -if {"[info procs GetSelection]" == ""} { -proc GetSelection {} { -# xf ignore me 7 -########## -# Procedure: GetSelection -# Description: get current selection -# Arguments: none -# Returns: none -# Sideeffects: none -########## - - # the save way - set xfSelection "" - catch "selection get" xfSelection - if {"$xfSelection" == "selection doesn't exist or form \"STRING\" not defined"} { - return "" - } { - return $xfSelection - } -} -} - - -# Procedure: MenuPopupAdd -if {"[info procs MenuPopupAdd]" == ""} { -proc MenuPopupAdd { xfW xfButton xfMenu {xfModifier ""} {xfCanvasTag ""}} { -# xf ignore me 7 -# the popup menu handling is from (I already gave up with popup handling :-): -# -# Copyright 1991,1992 by James Noble. -# Everyone is granted permission to copy, modify and redistribute. -# This notice must be preserved on all copies or derivates. -# -########## -# Procedure: MenuPopupAdd -# Description: attach a popup menu to widget -# Arguments: xfW - the widget -# xfButton - the button we use -# xfMenu - the menu to attach -# {xfModifier} - a optional modifier -# {xfCanvasTag} - a canvas tagOrId -# Returns: none -# Sideeffects: none -########## - global tk_popupPriv - - set tk_popupPriv($xfMenu,focus) "" - set tk_popupPriv($xfMenu,grab) "" - if {"$xfModifier" != ""} { - set press "$xfModifier-" - set motion "$xfModifier-" - set release "Any-" - } { - set press "" - set motion "" - set release "" - } - - bind $xfMenu "<${motion}B${xfButton}-Motion>" "MenuPopupMotion $xfMenu %W %X %Y" - bind $xfMenu "<${release}ButtonRelease-${xfButton}>" "MenuPopupRelease $xfMenu %W" - if {"$xfCanvasTag" == ""} { - bind $xfW "<${press}ButtonPress-${xfButton}>" "MenuPopupPost $xfMenu %X %Y" - bind $xfW "<${release}ButtonRelease-${xfButton}>" "MenuPopupRelease $xfMenu %W" - } { - $xfW bind $xfCanvasTag "<${press}ButtonPress-${xfButton}>" "MenuPopupPost $xfMenu %X %Y" - $xfW bind $xfCanvasTag "<${release}ButtonRelease-${xfButton}>" "MenuPopupRelease $xfMenu %W" - } -} -} - - -# Procedure: MenuPopupMotion -if {"[info procs MenuPopupMotion]" == ""} { -proc MenuPopupMotion { xfMenu xfW xfX xfY} { -# xf ignore me 7 -########## -# Procedure: MenuPopupMotion -# Description: handle the popup menu motion -# Arguments: xfMenu - the topmost menu -# xfW - the menu -# xfX - the root x coordinate -# xfY - the root x coordinate -# Returns: none -# Sideeffects: none -########## - global tk_popupPriv - - if {"[info commands $xfW]" != "" && [winfo ismapped $xfW] && - "[winfo class $xfW]" == "Menu" && - [info exists tk_popupPriv($xfMenu,focus)] && - "$tk_popupPriv($xfMenu,focus)" != "" && - [info exists tk_popupPriv($xfMenu,grab)] && - "$tk_popupPriv($xfMenu,grab)" != ""} { - set xfPopMinX [winfo rootx $xfW] - set xfPopMaxX [expr $xfPopMinX+[winfo width $xfW]] - if {$xfX >= $xfPopMinX && $xfX <= $xfPopMaxX} { - $xfW activate @[expr $xfY-[winfo rooty $xfW]] - if {![catch "$xfW entryconfig @[expr $xfY-[winfo rooty $xfW]] -menu" result]} { - if {"[lindex $result 4]" != ""} { - foreach binding [bind $xfMenu] { - bind [lindex $result 4] $binding [bind $xfMenu $binding] - } - } - } - } { - $xfW activate none - } - } -} -} - - -# Procedure: MenuPopupPost -if {"[info procs MenuPopupPost]" == ""} { -proc MenuPopupPost { xfMenu xfX xfY} { -# xf ignore me 7 -########## -# Procedure: MenuPopupPost -# Description: post the popup menu -# Arguments: xfMenu - the menu -# xfX - the root x coordinate -# xfY - the root x coordinate -# Returns: none -# Sideeffects: none -########## - global tk_popupPriv - - if {"[info commands $xfMenu]" != ""} { - if {![info exists tk_popupPriv($xfMenu,focus)]} { - set tk_popupPriv($xfMenu,focus) [focus] - } { - if {"$tk_popupPriv($xfMenu,focus)" == ""} { - set tk_popupPriv($xfMenu,focus) [focus] - } - } - set tk_popupPriv($xfMenu,grab) $xfMenu - - catch "$xfMenu activate none" - catch "$xfMenu post $xfX $xfY" - catch "focus $xfMenu" - catch "grab -global $xfMenu" - } -} -} - - -# Procedure: MenuPopupRelease -if {"[info procs MenuPopupRelease]" == ""} { -proc MenuPopupRelease { xfMenu xfW} { -# xf ignore me 7 -########## -# Procedure: MenuPopupRelease -# Description: remove the popup menu -# Arguments: xfMenu - the topmost menu widget -# xfW - the menu widget -# Returns: none -# Sideeffects: none -########## - global tk_popupPriv - global tkVersion - - if {"[info commands $xfW]" != "" && [winfo ismapped $xfW] && - "[winfo class $xfW]" == "Menu" && - [info exists tk_popupPriv($xfMenu,focus)] && - "$tk_popupPriv($xfMenu,focus)" != "" && - [info exists tk_popupPriv($xfMenu,grab)] && - "$tk_popupPriv($xfMenu,grab)" != ""} { - if {$tkVersion >= 3.0} { - catch "grab release $tk_popupPriv($xfMenu,grab)" - } { - catch "grab none" - } - catch "focus $tk_popupPriv($xfMenu,focus)" - set tk_popupPriv($xfMenu,focus) "" - set tk_popupPriv($xfMenu,grab) "" - if {"[$xfW index active]" != "none"} { - $xfW invoke active; catch "$xfMenu unpost" - } - } - catch "$xfMenu unpost" -} -} - - -# Procedure: NoFunction -if {"[info procs NoFunction]" == ""} { -proc NoFunction { args} { -# xf ignore me 7 -########## -# Procedure: NoFunction -# Description: do nothing (especially with scales and scrollbars) -# Arguments: args - a number of ignored parameters -# Returns: none -# Sideeffects: none -########## -} -} - - -# Procedure: SN -if {"[info procs SN]" == ""} { -proc SN { {xfName ""}} { -# xf ignore me 7 -########## -# Procedure: SN -# Description: map a symbolic name to the widget path -# Arguments: xfName -# Returns: the symbolic name -# Sideeffects: none -########## - - SymbolicName $xfName -} -} - - -# Procedure: SymbolicName -if {"[info procs SymbolicName]" == ""} { -proc SymbolicName { {xfName ""}} { -# xf ignore me 7 -########## -# Procedure: SymbolicName -# Description: map a symbolic name to the widget path -# Arguments: xfName -# Returns: the symbolic name -# Sideeffects: none -########## - - global symbolicName - - if {"$xfName" != ""} { - set xfArrayName "" - append xfArrayName symbolicName ( $xfName ) - if {![catch "set \"$xfArrayName\"" xfValue]} { - return $xfValue - } { - if {"[info commands XFProcError]" != ""} { - XFProcError "Unknown symbolic name:\n$xfName" - } { - puts stderr "XF error: unknown symbolic name:\n$xfName" - } - } - } - return "" -} -} - - -# Procedure: Unalias -if {"[info procs Unalias]" == ""} { -proc Unalias { aliasName} { -# xf ignore me 7 -########## -# Procedure: Unalias -# Description: remove an alias for a procedure -# Arguments: aliasName - the alias name to remove -# Returns: none -# Sideeffects: internalAliasList is updated, and the alias -# proc is removed -########## - global internalAliasList - - set xfIndex [lsearch $internalAliasList "$aliasName *"] - if {$xfIndex != -1} { - rename $aliasName "" - set internalAliasList [lreplace $internalAliasList $xfIndex $xfIndex] - } -} -} - - - -# application parsing procedure -proc XFLocalParseAppDefs {xfAppDefFile} { - global xfAppDefaults - - # basically from: Michael Moore - if {[file exists $xfAppDefFile] && - [file readable $xfAppDefFile] && - "[file type $xfAppDefFile]" == "link"} { - catch "file type $xfAppDefFile" xfType - while {"$xfType" == "link"} { - if {[catch "file readlink $xfAppDefFile" xfAppDefFile]} { - return - } - catch "file type $xfAppDefFile" xfType - } - } - if {!("$xfAppDefFile" != "" && - [file exists $xfAppDefFile] && - [file readable $xfAppDefFile] && - "[file type $xfAppDefFile]" == "file")} { - return - } - if {![catch "open $xfAppDefFile r" xfResult]} { - set xfAppFileContents [read $xfResult] - close $xfResult - foreach line [split $xfAppFileContents "\n"] { - # backup indicates how far to backup. It applies to the - # situation where a resource name ends in . and when it - # ends in *. In the second case you want to keep the * - # in the widget name for pattern matching, but you want - # to get rid of the . if it is the end of the name. - set backup -2 - set line [string trim $line] - if {[string index $line 0] == "#" || "$line" == ""} { - # skip comments and empty lines - continue - } - set list [split $line ":"] - set resource [string trim [lindex $list 0]] - set i [string last "." $resource] - set j [string last "*" $resource] - if {$j > $i} { - set i $j - set backup -1 - } - incr i - set name [string range $resource $i end] - incr i $backup - set widname [string range $resource 0 $i] - set value [string trim [lindex $list 1]] - if {"$widname" != "" && "$widname" != "*"} { - # insert the widget and resourcename to the application - # defaults list. - if {![info exists xfAppDefaults]} { - set xfAppDefaults "" - } - lappend xfAppDefaults [list $widname [string tolower $name] $value] - } - } - } -} - -# application loading procedure -proc XFLocalLoadAppDefs {{xfClasses ""} {xfPriority "startupFile"} {xfAppDefFile ""}} { - global env - - if {"$xfAppDefFile" == ""} { - set xfFileList "" - if {[info exists env(XUSERFILESEARCHPATH)]} { - append xfFileList [split $env(XUSERFILESEARCHPATH) :] - } - if {[info exists env(XAPPLRESDIR)]} { - append xfFileList [split $env(XAPPLRESDIR) :] - } - if {[info exists env(XFILESEARCHPATH)]} { - append xfFileList [split $env(XFILESEARCHPATH) :] - } - append xfFileList " /usr/lib/X11/app-defaults" - append xfFileList " /usr/X11/lib/X11/app-defaults" - - foreach xfCounter1 $xfClasses { - foreach xfCounter2 $xfFileList { - set xfPathName $xfCounter2 - if {[regsub -all "%N" "$xfPathName" "$xfCounter1" xfResult]} { - set xfPathName $xfResult - } - if {[regsub -all "%T" "$xfPathName" "app-defaults" xfResult]} { - set xfPathName $xfResult - } - if {[regsub -all "%S" "$xfPathName" "" xfResult]} { - set xfPathName $xfResult - } - if {[regsub -all "%C" "$xfPathName" "" xfResult]} { - set xfPathName $xfResult - } - if {[file exists $xfPathName] && - [file readable $xfPathName] && - ("[file type $xfPathName]" == "file" || - "[file type $xfPathName]" == "link")} { - catch "option readfile $xfPathName $xfPriority" - if {"[info commands XFParseAppDefs]" != ""} { - XFParseAppDefs $xfPathName - } { - if {"[info commands XFLocalParseAppDefs]" != ""} { - XFLocalParseAppDefs $xfPathName - } - } - } { - if {[file exists $xfCounter2/$xfCounter1] && - [file readable $xfCounter2/$xfCounter1] && - ("[file type $xfCounter2/$xfCounter1]" == "file" || - "[file type $xfCounter2/$xfCounter1]" == "link")} { - catch "option readfile $xfCounter2/$xfCounter1 $xfPriority" - if {"[info commands XFParseAppDefs]" != ""} { - XFParseAppDefs $xfCounter2/$xfCounter1 - } { - if {"[info commands XFLocalParseAppDefs]" != ""} { - XFLocalParseAppDefs $xfCounter2/$xfCounter1 - } - } - } - } - } - } - } { - # load a specific application defaults file - if {[file exists $xfAppDefFile] && - [file readable $xfAppDefFile] && - ("[file type $xfAppDefFile]" == "file" || - "[file type $xfAppDefFile]" == "link")} { - catch "option readfile $xfAppDefFile $xfPriority" - if {"[info commands XFParseAppDefs]" != ""} { - XFParseAppDefs $xfAppDefFile - } { - if {"[info commands XFLocalParseAppDefs]" != ""} { - XFLocalParseAppDefs $xfAppDefFile - } - } - } - } -} - -# application setting procedure -proc XFLocalSetAppDefs {{xfWidgetPath "."}} { - global xfAppDefaults - - if {![info exists xfAppDefaults]} { - return - } - foreach xfCounter $xfAppDefaults { - if {"$xfCounter" == ""} { - break - } - set widname [lindex $xfCounter 0] - if {[string match $widname ${xfWidgetPath}] || - [string match "${xfWidgetPath}*" $widname]} { - set name [string tolower [lindex $xfCounter 1]] - set value [lindex $xfCounter 2] - # Now lets see how many tcl commands match the name - # pattern specified. - set widlist [info command $widname] - if {"$widlist" != ""} { - foreach widget $widlist { - # make sure this command is a widget. - if {![catch "winfo id $widget"] && - [string match "${xfWidgetPath}*" $widget]} { - catch "$widget configure -$name $value" - } - } - } - } - } -} - - -# prepare auto loading -global auto_path -global tk_library -global xfLoadPath -foreach xfElement [eval list [split $xfLoadPath :] $auto_path] { - if {[file exists $xfElement/tclIndex]} { - lappend auto_path $xfElement - } -} -catch "unset auto_index" - -catch "unset auto_oldpath" - -catch "unset auto_execs" - - -# initialize global variables -proc InitGlobals {} { - global {checkbutton5} - set {checkbutton5} {0} - global {fsBox} - set {fsBox(activeBackground)} {} - set {fsBox(activeForeground)} {} - set {fsBox(all)} {0} - set {fsBox(background)} {} - set {fsBox(button)} {0} - set {fsBox(extensions)} {0} - set {fsBox(font)} {} - set {fsBox(foreground)} {} - set {fsBox(internalPath)} {/user/kono/ITL/demo} - set {fsBox(name)} {ahoaho} - set {fsBox(path)} {/user/kono/ITL/demo} - set {fsBox(pattern)} {*} - set {fsBox(scrollActiveForeground)} {} - set {fsBox(scrollBackground)} {} - set {fsBox(scrollForeground)} {} - set {fsBox(scrollSide)} {left} - set {fsBox(showPixmap)} {0} - global {inputBox} - set {inputBox(activeBackground)} {} - set {inputBox(activeForeground)} {} - set {inputBox(anchor)} {n} - set {inputBox(background)} {} - set {inputBox(erase)} {1} - set {inputBox(font)} {} - set {inputBox(foreground)} {} - set {inputBox(justify)} {center} - set {inputBox(scrollActiveForeground)} {} - set {inputBox(scrollBackground)} {} - set {inputBox(scrollForeground)} {} - set {inputBox(scrollSide)} {left} - set {inputBox(toplevelName)} {.inputBox} - global {scalex} - set {scalex} {326} - global {scaley} - set {scaley} {194} - global {verbose} - set {verbose} {0} - - # please don't modify the following - # variables. They are needed by xf. - global {autoLoadList} - set {autoLoadList(xf-disp)} {0} - global {internalAliasList} - set {internalAliasList} {} - global {moduleList} - set {moduleList(xf-disp)} {} - global {preloadList} - set {preloadList(xfInternal)} {} - global {symbolicName} - set {symbolicName(canvas)} {.top0.frame0.canvas2} - set {symbolicName(diag)} {.top0.frame6.button8} - set {symbolicName(entry)} {.frame.frame4.text0} - set {symbolicName(execute)} {.top0.frame6.button10} - set {symbolicName(generate)} {.top0.frame1.button0} - set {symbolicName(map)} {.top0.frame1.button13} - set {symbolicName(root)} {.} - set {symbolicName(states)} {.top0.frame1.label6} - set {symbolicName(verbose)} {.frame3.checkbutton5} - set {symbolicName(verify)} {.frame3.button7} - global {xfWmSetPosition} - set {xfWmSetPosition} {} - global {xfWmSetSize} - set {xfWmSetSize} {} - global {xfAppDefToplevels} - set {xfAppDefToplevels} {} -} - -# initialize global variables -InitGlobals - -# display/remove toplevel windows. -ShowWindow. - -global xfShowWindow.top0 -set xfShowWindow.top0 1 -ShowWindow.top0 - -# load default bindings. -if {[info exists env(XF_BIND_FILE)] && - "[info procs XFShowHelp]" == ""} { - source $env(XF_BIND_FILE) -} - -# parse and apply application defaults. -XFLocalLoadAppDefs Xf-disp -XFLocalSetAppDefs - -# eof -# -