Import LinuxCNC source tree

share/axis/tcl/accel.tcl

@@ -0,0 +1,187 @@
+#  Nf Screen designer for Tk toolkit
+#  Copyright (C) 2004 Jeff Epler <jepler@unpythonic.net>
+#
+#  This program is free software; you can redistribute it and/or modify
+#  it under the terms of the GNU General Public License as published by
+#  the Free Software Foundation; either version 2 of the License, or
+#  (at your option) any later version.
+#
+#  This program is distributed in the hope that it will be useful,
+#  but WITHOUT ANY WARRANTY; without even the implied warranty of
+#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+#  GNU General Public License for more details.
+#
+#  You should have received a copy of the GNU General Public License
+#  along with this program; if not, write to the Free Software
+#  Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+
+# Each label, button, checkbutton, radiobutton, and menubutton can have
+# an underlined accelerator key.
+#
+# To activate an accelerator key K, Alt+K is pressed.
+#
+# If only one item has this accelerator, then the associated widget
+# is invoked.  If the associated "widget" is a group of radio buttons,
+# the next option is selected.  For buttons, the associated widget is
+# the button itself.  For labels, the associated widget is intended
+# to be the same as the widget selected by "label_button" (though the
+# definition of label_hotkey is different)
+#
+# If more than one item has this accelerator, then focus is merely moved
+# to the item.
+
+
+proc make_accel { label underline } {
+    if {$underline == -1} {
+        regsub -all {([\\_])} $label {\\\1} label
+        return $label
+    }
+    set a [string range $label 0 [expr $underline-1]]
+    set b [string range $label $underline end]
+    regsub -all {([\\_])} $a {\\\1} a
+    regsub -all {([\\_])} $b {\\\1} b
+    return "${a}_${b}"
+}
+
+proc decode_accel { label } {
+    set index -1
+    if {[regexp {^([^\\_]|\\.)*_} $label match]} {
+        set index [expr [string length $match]-1]
+        set a [string range $label 0 [expr $index-1]]
+        set b [string range $label [expr $index+1] end]
+        regsub -all {\\(.)} $a {\1} a    
+        regsub -all {\\(.)} $b {\1} b    
+        set index [string length $a]
+        set label ${a}$b
+        return [list $index $label]
+    }
+    regsub -all {\\(.)} $label {\1} label    
+    return [list -1 $label]
+}
+
+proc clear_accel_map {} {
+    global _accel _last_accel
+    catch { unset _accel }
+    set _last_accel {}
+}
+
+proc label_hotkey {w {activate 1}} {
+    set x [tk_focusNext $w]
+    set y [tk_focusNext $x]
+
+    set px [winfo parent $x]
+    set py [winfo parent $y]
+
+    if {$px == $py} {
+        # Next two choices are siblings
+        # must be a radiobutton
+        set idx -1
+        set spx [pack slaves $px]
+        foreach k $spx {
+            set v [$k cget -variable]
+            upvar \#0 $v val
+            if {[$k cget -value] == $val} {
+                set idx [lsearch $spx $k]
+            }
+        }
+        if {$activate} {
+            set idx [expr ($idx+1) % [llength $spx]]
+        } elseif {$idx == -1} {
+                set idx 0
+        }
+        set w [lindex $spx $idx]
+    } else {
+        set w $x
+    }
+    if {$activate} {
+        switch [winfo class $w] {
+            Button -
+            Checkbutton -
+            Radiobutton -
+            Menubutton {
+                $w invoke
+            }
+            Entry {
+                $w select 0 end
+            }
+            Combobox {
+                $w open
+            }
+            default {}
+        }
+    }
+    tkTabToWindow $w
+}
+
+proc see_accel {w k} {
+    global _accel _last_accel _last_widget
+    set w [winfo toplevel $w]
+    if {![info exists _accel($k,$w)]} { return 0 }
+    set accel $_accel($k,$w)
+    if {$k == $_last_accel} {
+        set idx [expr ([lsearch $accel $_last_widget]+1) % [llength $accel]]
+    } else {
+        set idx 0
+    }
+    set w [lindex $accel $idx]
+    set _last_accel $k
+    set _last_widget $w
+    set k [winfo class $w]
+    switch $k {
+        Button -
+        Menubutton -
+        Checkbutton -
+        Radiobutton {
+            if {[llength $accel] == 1} {
+                $w invoke
+            } else {
+                focus $w
+            }
+        }
+        Label {
+            label_hotkey $w [expr [llength $accel] == 1]
+        }
+    }
+    return 1
+}
+
+bind all <Alt-Key> [concat {if {[see_accel %W %A]} break;} [bind all <Alt-Key>]]
+
+proc setup_menu_accel { path item label } {
+    set li [decode_accel $label]
+    set index [lindex $li 0]
+    set label [lindex $li 1]
+    $path entryconfigure $item -underline $index -label $label
+}
+
+proc setup_widget_accel { path label } {
+    set li [decode_accel $label]
+    set index [lindex $li 0]
+    set label [lindex $li 1]
+    $path configure -underline $index -text $label
+    if {$index != -1} {
+        global _accel
+        set char [string tolower [string index $label $index]]
+        set w [winfo toplevel $path]
+        lappend _accel($char,$w) $path
+    }
+}
+
+proc extract_text { label } {
+    set li [decode_accel $label]
+    lindex $li 1
+}
+
+proc sbind { tag seq body } {
+    catch { bind $tag $seq $body }
+}
+
+sbind all <Key-ISO_Left_Tab> { tkTabToWindow [tk_focusPrev %W] }
+
+if {[info procs ::tk::TabToWindow] != {}} {
+    proc tkTabToWindow w [info body ::tk::TabToWindow]
+}
+
+clear_accel_map
+
+# vim:sw=4:sts=4:

share/axis/tcl/dialog.tcl

@@ -0,0 +1,261 @@
+#  Nf Screen designer for Tk toolkit
+#  Copyright (C) 2004 Jeff Epler <jepler@unpythonic.net>
+#
+#  This program is free software; you can redistribute it and/or modify
+#  it under the terms of the GNU General Public License as published by
+#  the Free Software Foundation; either version 2 of the License, or
+#  (at your option) any later version.
+#
+#  This program is distributed in the hope that it will be useful,
+#  but WITHOUT ANY WARRANTY; without even the implied warranty of
+#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+#  GNU General Public License for more details.
+#
+#  You should have received a copy of the GNU General Public License
+#  along with this program; if not, write to the Free Software
+#  Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+
+# dialog.tcl --
+#
+# This file defines the procedure nf_dialog, which creates a dialog
+# box containing an image, a message, and one or more buttons.
+#
+# RCS: @(#) $Id$
+#
+# Copyright (c) 1992-1993 The Regents of the University of California.
+# Copyright (c) 1994-1997 Sun Microsystems, Inc.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+
+proc patient_grab w {
+    set ret [catch { grab $w } res]
+    if {!$ret} { return }
+    set sei $::errorInfo
+    if {$res == "grab failed: another application has grab"
+        || $res == "grab failed: window not viewable"} {
+        after 100
+        after idle patient_grab $w
+    } else {
+        error $ret $savedInfo
+    }
+}
+
+#
+# nf_dialog:
+#
+# This procedure displays a dialog box, waits for a button in the dialog
+# to be invoked, then returns the index of the selected button.  If the
+# dialog somehow gets destroyed, -1 is returned.
+#
+# Arguments:
+# w -		Window to use for dialog top-level.
+#
+#               If it is a list, then it is of the form {w args}
+#               where args (different from the 'args' below) specify
+#               extra keyword arguments:
+#		    -ext ...: show ... in a scrolling text area below the main
+#		              text
+# title -	Title to display in dialog's decorative frame.
+# text -	Message to display in dialog.
+# image -	Image to display in dialog (empty string means none).
+# default -	Index of button that is to display the default ring
+#		(-1 means none).
+# args -	One or more strings to display in buttons across the
+#		bottom of the dialog box.
+
+proc nf_dialog_default {t n i} {
+    for {set j 0} {$j < $n} {incr j} {
+	if {$i == $j} {
+	    $t.button$j configure -default active
+	} else {
+	    $t.button$j configure -default normal
+	}
+    }
+}
+
+proc nf_dialog {w title text image default args} {
+    global tkPriv tcl_platform
+
+    set pargs [lrange $w 1 end]
+    set w [lindex $w 0]
+
+    set ext {}
+    foreach {k v} $pargs {
+	switch -- $k {
+	-ext { set ext $v }
+	default { error "nf_dialog: unexpected positional argument $k $v" }
+	}
+    }
+
+    if {[llength $default] != 1} {
+        set accel $default
+        set default [lsearch $accel -2]
+    } else {
+        set accel {}
+    }
+
+    # 1. Create the top-level window and divide it into top
+    # and bottom parts.
+
+    catch {destroy $w}
+    toplevel $w -class Dialog
+    wm title $w $title
+    wm iconname $w Dialog
+    wm protocol $w WM_DELETE_WINDOW { }
+    wm resiz $w 0 0
+
+    # The following command means that the dialog won't be posted if
+    # [winfo parent $w] is iconified, but it's really needed;  otherwise
+    # the dialog can become obscured by other windows in the application,
+    # even though its grab keeps the rest of the application from being used.
+
+    wm transient $w [winfo toplevel [winfo parent $w]]
+    if {![string compare $tcl_platform(platform) "macintosh"]} {
+	unsupported1 style $w dBoxProc
+    }
+
+    frame $w.bot
+    frame $w.top 
+    if {[llength $args] == 1} {
+	pack $w.bot -side bottom -fill both
+    } else {
+	pack $w.bot -side bottom -fill none -anchor e -expand 1
+    }
+    pack $w.top -side top -fill both -expand 1
+
+    # 2. Fill the top part with image and message (use the option
+    # database for -wraplength and -font so that they can be
+    # overridden by the caller).
+
+    option add *Dialog.msg.wrapLength 7i widgetDefault
+    if {![string compare $tcl_platform(platform) "macintosh"]} {
+	option add *Dialog.msg.font system widgetDefault
+    } else {
+	option add *Dialog.msg.font {Times 12} widgetDefault
+    }
+
+    label $w.msg -justify left -text $text
+    pack $w.msg -in $w.top -side right -expand 1 -fill both -padx 3m -pady 3m
+    if {[string compare $image ""]} {
+      if {![string compare $tcl_platform(platform) "macintosh"] && ![string compare $image "error"]} {
+	    set image "stop"
+	}
+	label $w.image -image [load_image std_$image]
+	pack $w.image -in $w.top -side left -padx 3m -pady 3m
+    }
+
+    if {$ext != {}} {
+	frame $w.ext
+	text $w.ext.t -yscrollcommand [list $w.ext.s set] -wrap word
+	scrollbar $w.ext.s -command [list $w.ext.t yview] -orient v
+	pack $w.ext.t -side left -fill both -expand 1
+	pack $w.ext.s -side left -fill y
+	$w.ext.t insert end $ext
+	$w.ext.t configure -state disabled
+	pack $w.ext -side top
+    }
+
+    # 3. Create a row of buttons at the bottom of the dialog.
+
+    set i 0
+    set l [llength $args]
+    foreach but $args {
+	button $w.button$i -text $but -command "set tkPriv(button) $i" \
+            -width 10 -height 1 -padx 0 -pady .25 
+
+        set u [lindex $accel $i]
+
+	bind $w.button$i <FocusIn> [list nf_dialog_default $w $l $i]
+
+        if {$u == -3} {
+            bind $w <Escape> "$w.button$i flash; set tkPriv(button) $i"
+        }
+	bind $w.button$i <Return> {%W flash; %W invoke}
+
+        if {$u >= 0} {
+            set c [string index $but $u]
+            bind $w "[string tolower $c]" \
+                    "$w.button$i flash; set tkPriv(button) $i"
+            $w.button$i configure -underline $u
+        }
+
+	grid $w.button$i -in $w.bot -column $i -row 0 -sticky ew -padx 3 -pady 3
+	grid columnconfigure $w.bot $i
+
+        set f [$w.button$i cget -font]
+        set bwidth [expr 9 * [font measure $f "0"]]
+        set twidth [font measure $f $but]
+        if {$twidth > $bwidth} {
+            $w.button$i configure -width 0 -padx .25m
+        }
+
+	incr i
+    }
+
+    # 4. Create a <Destroy> binding for the window that sets the
+    # button variable to -1;  this is needed in case something happens
+    # that destroys the window, such as its parent window being destroyed.
+
+    bind $w <Destroy> {set tkPriv(button) -1}
+
+    # 5. Withdraw the window, then update all the geometry information
+    # so we know how big it wants to be, then center the window in the
+    # display and de-iconify it.
+
+    wm withdraw $w
+    update idletasks
+
+    set parent [winfo parent $w]
+    if {[winfo viewable $parent]} { 
+        set x [expr {[winfo rootx $parent]+([winfo reqwidth $parent]-[winfo reqwidth $w])/2}]
+        set y [expr {[winfo rooty $parent]+([winfo reqheight $parent]-[winfo reqheight $w])/2}]
+    } else {
+        set x [expr {([winfo screenwidth $w]-[winfo reqwidth $w])/2}]
+        set y [expr {([winfo screenheight $w]-[winfo reqheight $w])/2}]
+    }
+    wm geom $w +$x+$y
+    wm deiconify $w
+
+    # 6. Set a grab and claim the focus too.
+
+    set oldFocus [focus]
+    set oldGrab [grab current $w]
+    if {[string compare $oldGrab ""]} {
+	set grabStatus [grab status $oldGrab]
+    }
+    patient_grab $w
+    if {$default >= 0} {
+	focus $w.button$default
+    } else {
+	focus $w
+    }
+
+    # 7. Wait for the user to respond, then restore the focus and
+    # return the index of the selected button.  Restore the focus
+    # before deleting the window, since otherwise the window manager
+    # may take the focus away so we can't redirect it.  Finally,
+    # restore any grab that was in effect.
+
+    tkwait variable tkPriv(button)
+    catch {focus $oldFocus}
+    catch {
+	# It's possible that the window has already been destroyed,
+	# hence this "catch".  Delete the Destroy handler so that
+	# tkPriv(button) doesn't get reset by it.
+
+	bind $w <Destroy> {}
+	destroy $w
+    }
+    if {[string compare $oldGrab ""]} {
+      if {[string compare $grabStatus "global"]} {
+	    grab $oldGrab
+      } else {
+          grab -global $oldGrab
+	}
+    }
+    return $tkPriv(button)
+}
+
+# vim:sw=4:sts=4:

share/axis/tcl/sb.tcl

@@ -0,0 +1,108 @@
+#  Nf Screen designer for Tk toolkit
+#  Copyright (C) 2004 Jeff Epler <jepler@unpythonic.net>
+#
+#  This program is free software; you can redistribute it and/or modify
+#  it under the terms of the GNU General Public License as published by
+#  the Free Software Foundation; either version 2 of the License, or
+#  (at your option) any later version.
+#
+#  This program is distributed in the hope that it will be useful,
+#  but WITHOUT ANY WARRANTY; without even the implied warranty of
+#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+#  GNU General Public License for more details.
+#
+#  You should have received a copy of the GNU General Public License
+#  along with this program; if not, write to the Free Software
+#  Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+
+namespace eval ::sb {}
+
+proc ::sb::arrow_size_vertical {w} {
+    set xx [expr [::sb::_$w cget -bd]+1]
+    for {set i [expr [::sb::_$w cget -bd]+1]} {1} {incr i} {
+        set part [::sb::_$w identify $xx $i]
+        if {$part != "arrow1"} { return $i }
+    }
+}
+proc ::sb::arrow_size_horizontal {w} {
+    set yy [expr [::sb::_$w cget -bd]+1]
+    for {set i [expr [::sb::_$w cget -bd]+1]} {1} {incr i} {
+        set part [::sb::_$w identify $i $yy]
+        if {$part != "arrow1"} { return $i }
+    }
+}
+
+image create bitmap ::sb::uparrow -file $imagedir/uparrow.xbm
+image create bitmap ::sb::downarrow -file $imagedir/downarrow.xbm
+image create bitmap ::sb::leftarrow -file $imagedir/leftarrow.xbm
+image create bitmap ::sb::rightarrow -file $imagedir/rightarrow.xbm
+
+bind ::sb::nicer <Configure> { ::sb::nicer_config %W }
+proc ::sb::nicer_sb {w} {
+    bindtags $w [concat ::sb::nicer [bindtags $w]]
+    ::sb::_$w configure -bd 0 -highlightt 0
+    ::sb::nicer_config $w
+}
+
+proc ::sb::nicer_config {w} {
+    set o [::sb::_$w cget -orient]
+    if {![winfo exists ${w}._arrow1]} {
+        button ${w}._arrow1
+    } 
+    if {![winfo exists ${w}._arrow2]} {
+        button ${w}._arrow2
+    } 
+    
+    if {[string match "v*" $o]} {
+        set sz [::sb::arrow_size_vertical $w]
+        set width [winfo width $w]
+        ${w}._arrow1 config -image ::sb::uparrow   -takefocus 0 -highlightt 0 \
+            -anchor center
+        ${w}._arrow2 config -image ::sb::downarrow -takefocus 0 -highlightt 0 \
+            -anchor center
+        place ${w}._arrow1 -x 0 -y 0 \
+            -width $width -height $sz
+        place ${w}._arrow2 -x 0 -y [expr [winfo height $w]-$sz] \
+            -width $width -height $sz
+    } else {
+        set sz [::sb::arrow_size_horizontal $w]
+        set height [winfo height $w]
+        ${w}._arrow1 config -image ::sb::leftarrow -takefocus 0 -highlightt 0 \
+            -anchor center
+        ${w}._arrow2 config -image ::sb::rightarrow -takefocus 0 -highlightt 0 \
+            -anchor center
+        place ${w}._arrow1 -x 0 -y 0 \
+            -width $sz -height $height
+        place ${w}._arrow2 -x [expr [winfo width $w]-$sz] -y 0 \
+            -width $sz -height $height
+    }
+    foreach b {
+        <1> <B1-Leave> <ButtonRelease-1> <B1-Enter> <Leave> <Enter>
+    } {
+        bind ${w}._arrow1 $b [subst -nocommands {
+            event generate $w $b \
+                -x [expr %x+[winfo x %W]] \
+                -y [expr %y+[winfo y %W]]
+        }]
+        bind ${w}._arrow2 $b [subst -nocommands {
+            event generate $w $b \
+                -x [expr %x+[winfo x %W]] \
+                -y [expr %y+[winfo y %W]]
+        }]
+    }
+}
+
+proc ::sb::install {} {
+    rename ::scrollbar ::sb::real_scrollbar
+    proc ::scrollbar { path args } {
+        eval [concat ::sb::real_scrollbar $path $args]
+        rename $path ::sb::_$path
+        proc $path { args } [subst -nocommands {
+            set ret [eval [concat ::sb::_$path \$args]]
+            ::sb::nicer_config $path
+            set ret
+        }]
+        ::sb::nicer_sb $path
+        set path
+    }
+}

share/axis/tcl/support.tcl

@@ -0,0 +1,65 @@
+#    This is a component of AXIS, a front-end for emc
+#    Copyright 2004 Jeff Epler <jepler@unpythonic.net> and
+#    Chris Radek <chris@timeguy.com>
+#
+#    This program is free software; you can redistribute it and/or modify
+#    it under the terms of the GNU General Public License as published by
+#    the Free Software Foundation; either version 2 of the License, or
+#    (at your option) any later version.
+#
+#    This program is distributed in the hope that it will be useful,
+#    but WITHOUT ANY WARRANTY; without even the implied warranty of
+#    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+#    GNU General Public License for more details.
+#
+#    You should have received a copy of the GNU General Public License
+#    along with this program; if not, write to the Free Software
+#    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+
+proc make_color { c d } {
+    if {![catch {winfo rgb . $c}]} {
+        set d $c
+    }
+    proc $c {} [list return $d]
+}
+
+make_color systemwindowtext      #000000
+make_color systembuttonface      #d9d9d9
+make_color systemdisabledtext    #a3a3a3
+make_color systembuttonhighlight #ececec
+make_color systemhighlight       #08246b
+make_color systemhighlighttext   #ffffff
+make_color systemwindow          #ffffff
+
+proc control {path args} { eval [concat frame $path $args -class Control] }
+proc vspace {path args} { eval [concat frame $path $args -class Vspace] }
+proc hspace {path args} { eval [concat frame $path $args -class Hspace] }
+proc vrule {path args} { eval [concat frame $path $args -class Vrule] }
+proc hrule {path args} { eval [concat frame $path $args -class Hrule] }
+proc tab {path args} { eval [concat frame $path] }
+
+proc find_image {name} {
+    set initial [string index $name 0]
+    foreach p $::imagedir {
+        set q [file join $p ${name}.png]
+        if {[file exists $q]} { return $q }
+        set q [file join $p $initial ${name}.png]
+        if {[file exists $q]} { return $q }
+        set q [file join $p ${name}.gif]
+        if {[file exists $q]} { return $q }
+        set q [file join $p $initial ${name}.gif]
+        if {[file exists $q]} { return $q }
+    }
+    error "Image $name does not exist"
+}
+
+
+proc load_image { name {img ""}} {
+    if {$img == ""} { set img icon_$name }
+    if {[lsearch [image names] $img] != -1}  { return $img }
+    set file [find_image $name]
+    image create photo $img -file $file
+    return $img
+}
+
+