Mercurial > hg > Applications > Lite
view tk/bou.tcl @ 10:f2aa38ce0787
add state display.
author | kono |
---|---|
date | Fri, 19 Jan 2001 23:14:00 +0900 |
parents | 1c57a78f1d98 |
children |
line wrap: on
line source
#!/usr/local/bin/wish -f # Program: bou # 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 .toy proc ShowWindow.toy {args} {# xf ignore me 7 # build widget .toy if {"[info procs XFEdit]" != ""} { catch "XFDestroy .toy" } { catch "destroy .toy" } toplevel .toy \ -background {Cornsilk2} \ -relief {raised} # Window manager configurations global tkVersion wm positionfrom .toy program wm sizefrom .toy program wm maxsize .toy 1000 1000 wm title .toy {Toy} # build widget .toy.frame1 frame .toy.frame1 \ -background {Cornsilk2} \ -borderwidth {2} \ -height {293} \ -relief {raised} \ -width {141} # build widget .toy.frame1.label2 label .toy.frame1.label2 \ -background {Cornsilk2} \ -font {8x16} \ -relief {raised} \ -text {Green} # build widget .toy.frame1.label3 label .toy.frame1.label3 \ -background {Cornsilk2} \ -font {8x16} \ -relief {raised} \ -text {Red} # build widget .toy.frame1.button4 button .toy.frame1.button4 \ -activebackground {#eed5b7} \ -background {Cornsilk2} \ -command {event quit} \ -disabledforeground {#b0b0b0} \ -font {8x16} \ -relief {flat} \ -text { Quit } # build widget .toy.frame1.button5 button .toy.frame1.button5 \ -activebackground {#eed5b7} \ -background {Cornsilk2} \ -command {event stop} \ -disabledforeground {#b0b0b0} \ -font {8x16} \ -text {Stop} # build widget .toy.frame1.button6 button .toy.frame1.button6 \ -activebackground {#eed5b7} \ -background {Cornsilk2} \ -command {event start} \ -disabledforeground {#b0b0b0} \ -font {8x16} \ -text {Run} # pack widget .toy.frame1 pack append .toy.frame1 \ .toy.frame1.label2 {top frame center fillx} \ .toy.frame1.label3 {top frame center fillx} \ .toy.frame1.button4 {bottom frame center fillx} \ .toy.frame1.button5 {bottom frame center fillx} \ .toy.frame1.button6 {bottom frame center fillx} # build widget .toy.canvas0 canvas .toy.canvas0 \ -background {Cornsilk2} \ -height {207} \ -insertofftime {600} \ -relief {raised} \ -selectbackground {#b2dfee} \ -selectborderwidth {1} \ -selectforeground {CornSilk2} \ -width {295} # pack widget .toy pack append .toy \ .toy.frame1 {right frame e filly} \ .toy.canvas0 {left frame center expand fill} # build canvas items .toy.canvas0 if {"[info procs XFEdit]" != ""} { catch "XFMiscBindWidgetTree .toy" after 2 "catch {XFEditSetShowWindows}" } } proc DestroyWindow.toy {} {# xf ignore me 7 if {"[info procs XFEdit]" != ""} { if {"[info commands .toy]" != ""} { global xfShowWindow.toy set xfShowWindow.toy 0 XFEditSetPath . after 2 "XFSaveAsProc .toy; XFEditSetShowWindows" } } { catch "destroy .toy" update } } # procedure to show window . proc ShowWindow. {args} {# xf ignore me 7 # Window manager configurations global tkVersion wm positionfrom . user wm sizefrom . "" wm maxsize . 1280 1024 wm title . {xf} if {"[info procs XFEdit]" != ""} { catch "XFMiscBindWidgetTree ." after 2 "catch {XFEditSetShowWindows}" } } # User defined procedures # Procedure: event proc event { args} { prolog "tokio:tokio_event($args)" # tokio } # 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 {now} set {now} {} # please don't modify the following # variables. They are needed by xf. global {autoLoadList} set {autoLoadList(bou.tcl)} {0} set {autoLoadList(main.tcl)} {0} global {internalAliasList} set {internalAliasList} {} global {moduleList} set {moduleList(bou.tcl)} {} global {preloadList} set {preloadList(xfInternal)} {} global {symbolicName} set {symbolicName(c)} {.canvas0} set {symbolicName(green)} {.frame1.label2} set {symbolicName(quit)} {.frame1.button4} set {symbolicName(red)} {.frame1.label3} set {symbolicName(root)} {.} set {symbolicName(run)} {.frame1.button6} set {symbolicName(stop)} {.frame1.button5} global {xfWmSetPosition} set {xfWmSetPosition} {} global {xfWmSetSize} set {xfWmSetSize} {} global {xfAppDefToplevels} set {xfAppDefToplevels} {} } # initialize global variables InitGlobals # display/remove toplevel windows. ShowWindow. global xfShowWindow.toy set xfShowWindow.toy 1 ShowWindow.toy # load default bindings. if {[info exists env(XF_BIND_FILE)] && "[info procs XFShowHelp]" == ""} { source $env(XF_BIND_FILE) } # parse and apply application defaults. XFLocalLoadAppDefs Bou XFLocalSetAppDefs # eof #