tools.tcl

This Source-Navigator, an IDE for C/C++/Fortran/Java/Tcl/PHP/Python and a host of other languages.

# Copyright (c) 2000, 2001, Red Hat, Inc.
# 
# This file is part of Source-Navigator.
# 
# Source-Navigator 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, or (at your option)
# any later version.
# 
# Source-Navigator 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 Source-Navigator; see the file COPYING.  If not, write to
# the Free Software Foundation, 59 Temple Place - Suite 330, Boston,
# MA 02111-1307, USA.
# 
# tools.tcl - Miscellaneous classes.
# Copyright (C) 1998, 1999 Cygnus Solutions.

##########################################
##
## Labeled entry
##
##########################################
option add *Entry&.width 5 widgetDefault
option add *Entry&.labelwidth -1 widgetDefault
option add *Entry&.state "normal" widgetDefault
option add *Entry&.exportselection y widgetDefault
option add *Entry&.underline -1 widgetDefault

itcl::class Entry& {
    inherit itk::Widget
    constructor {args} {

        itk_component add label {
            label $itk_interior.label
        } {
            rename -text -label label Label
            rename -width -labelwidth labelWidth Width
            keep -anchor -underline -state 
	}

	itk_component add entry {
	    entry $itk_interior.entry
	} {
	    keep -textvariable -exportselection -state -width
	}

        eval itk_initialize $args

	bind $itk_component(entry) <KeyPress> "
	    if {\[[itcl::code $this checkkeypress] %K\] == 1} {
	        continue
	    }
            bell
            break"

	pack $itk_component(label) -side $itk_option(-side)
        pack $itk_component(entry) -side $itk_option(-side)\
		-fill $itk_option(-fill) -expand $itk_option(-expand)

        if {$itk_option(-balloon) != ""} {
            balloon_bind_info $itk_component(entry) $itk_option(-balloon)
        }

        bind $itk_component(entry) <Tab> {focus [tk_focusNext %W]}
        bind $itk_component(entry) <Shift-Tab> {focus [tk_focusPrev %W]}
    }

    method checkkeypress {key {args ""}} {
	switch $itk_option(-filter) {
	    none { return 1 }
	    natural {
		if {$key == "BackSpace" \
			|| $key == "Delete" \
			|| $key == "Return"} {
		    return 1
		}
		if {[regexp {^[0-9]} $key] == 0} {
		    return 0
		}
	    }
	}
	return 1
    }    

    itk_option define -side side Side "left"

    itk_option define -anchor anchor Anchor "nw"

    itk_option define -fill fill Fill "both"

    itk_option define -expand expand Expand y

    itk_option define -balloon balloon Balloon ""

    itk_option define -filter filter Filter none {

	# Fixme: Currently only "none" and "natural" work.

	if {$itk_option(-filter) == "none"} {
	    # Unset all currently set filters.
	} elseif {$itk_option(-filter) == "posInt"} {
	    # Set filter for positive integers only (no zero).
	} elseif {$itk_option(-filter) == "natural"} {
	    # Set filter for positive integer and zero.
	} elseif {$itk_option(-filter) == "integer"} {
	    # Set filter for any integer value.
	} elseif {$itk_option(-filter) == "float"} {
	    # Any floating value.
	} else {
	    # Error condition
	    error "bad filter option \"$itk_option(-filter)\":\
		    should be none, posInt, natural, integer:\
		    or float."
	}
    }

}

##########################################
##
## Radio box
##
##########################################
itcl::class Radio& {
    inherit itk::Widget
    constructor {args} {

        eval itk_initialize $args

        if {$itk_option(-variable) == ""} {
            set itk_option(-variable) ${this}-value
        }

        if {$itk_option(-label) != ""} {
            label $itk_component(hull).label -text $itk_option(-label) -underline $itk_option(-labelunderline)
            pack $itk_component(hull).label -side $itk_option(-side) -fill x -expand n
            if {$itk_option(-labelwidth) != -1} {
                $itk_component(hull).label configure -width $itk_option(-labelwidth)
            }
        }

        set wdgs ""
        set i 0

        set fr $itk_component(hull)
        foreach n $itk_option(-labels) {
            set val [lindex $itk_option(-contents) ${i}]
            if {${val} == ""} {
                set val ${i}
            }
            set bal [lindex $itk_option(-balloons) ${i}]

            radiobutton ${fr}.radio-${i} -text ${n} -variable $itk_option(-variable)\
              -value ${val} -anchor $itk_option(-anchor) -underline $itk_option(-underline)

            pack ${fr}.radio-${i} -side $itk_option(-side) -fill x -expand $itk_option(-expand)\
              -anchor nw

            if {$itk_option(-command) != ""} {
                ${fr}.radio-${i} configure -command "eval $itk_option(-command)"
            }
            #bind balloon text
            if {${bal} != ""} {
                balloon_bind_info ${fr}.radio-${i} ${bal}
            }

            lappend wdgs ${fr}.radio-${i}

            incr i
        }
    }

    itk_option define -labelwidth labelwidth LabelWidth 20
    itk_option define -width width Width 20
    itk_option define -label label Label ""
    itk_option define -side side Side left
    itk_option define -fill fill Fill both
    itk_option define -expand expand Expand n
    itk_option define -anchor anchor Anchor nw
    itk_option define -variable variable Variable ""
    itk_option define -labels labels Labels ""
    itk_option define -contents contents Contents ""
    itk_option define -command command Command ""
    itk_option define -balloons balloons Balloons ""
    itk_option define -underline underline Underline -1
    itk_option define -labelunderline labelunderline Labelunderline -1
}

##########################################
##
## Checkbutton
##
##########################################
# 
# This class is just to created groups of
# checkbuttons.
#
# Basic usage:
# 
# CheckButton& <path> -labels <list of checkbutton labels>\
#                     -values <list of checkbutton values>\
#                     -variables <list of checkbutton variables>
#
# Other Notes:
#  This is not the best way to create and manage groups of
#  checkbuttons.  This needs a complete rewrite.
#
#########################################

itcl::class CheckButton& {
    inherit itk::Widget

    constructor {args} {

        eval itk_initialize $args

        itk_component add label {
            ::label $itk_interior.label
	} {
	    keep -underline
            rename -text -label text Text
	    rename -width -labelwidth labelWidth Width
	}
        pack $itk_component(label) -side ${side} -fill x -expand n

        set fr $itk_component(hull)
        set i 0
        foreach n $itk_option(-labels) {

            set var [lindex $itk_option(-variables) ${i}]
            set bal [lindex $itk_option(-balloons) ${i}]
            if {${var} == ""} {
                set var ${this}-${i}
            }
            set vals [lindex $itk_option(-values) ${i}]
            if {${vals} != ""} {
                set onval [lindex ${vals} 0]
                set offval [lindex ${vals} 1]
            } else {
                set onval 1
                set offval 0
            }
            set underline [lindex ${underlines} ${i}]
            if {${underline} == ""} {
                set underline -1
            }
            checkbutton ${fr}.check-${i} -text ${n} -variable ${var}\
              -onvalue ${onval} -offvalue ${offval} -anchor ${anchor}\
              -underline ${underline} -state ${state}

            pack ${fr}.check-${i} -side ${side} -fill x -expand ${expand}\
              -anchor nw

            if {${command} != ""} {
                ${fr}.check-${i} configure -command " eval ${command} "
            }
            #bind balloon text
            if {${bal} != ""} {
                balloon_bind_info ${fr}.check-${i} ${bal}
            }
            incr i
        }

        #when only a checkbutton is availiable and doesn't
        #have text, underline text widget.
        if {${labelunderline} == -1 && ${i} == 1 && ${n} == ""} {
            $itk_component(hull).label configure -underline ${underline}
        }
    }

    public variable labelwidth 20
    public variable width 20
    public variable label none
    public variable side left
    public variable fill both
    public variable expand n
    public variable anchor nw
    itk_option define -variables variables Variables ""
    public variable balloons ""
    itk_option define -labels labels Labels "on"
    itk_option define -values values Values ""
    public variable command ""
    public variable underlines -1
    public variable state "normal"
    public variable labelunderline -1
}


#############################################
# [Label Entry Button] widget
#############################################
itcl::class LabelEntryButton& {
    inherit itk::Widget
    constructor {args} {
        global sn_options

        itk_component add label {
            label $itk_component(hull).label
        } {
            rename -width -labelwidth labelWidth Width
            keep -underline -anchor -text
        }

        # entry for path
        itk_component add entry {
            ::entry $itk_interior.text
	} {
	    keep -state -width
	}

        itk_component add button {
	    button $itk_interior.button -text [get_indep String Choose]
        } {
            rename -underline -buttonunderline buttonUnderline Underline
            keep -state -command
        }

        # this should be add as an itk_option
        if {${buttonballoon} != ""} {
            balloon_bind_info $itk_component(button) ${buttonballoon}
        }

        eval itk_initialize $args

        # If no -command is set then bind the button to a
        # file selection dialog.
        if {$itk_option(-command) == ""} {
            $this configure -command [itcl::code ${this} select_file]
        }

        pack $itk_component(label) -side left -fill x
        pack $itk_component(entry) -side left -fill both -expand y
        pack $itk_component(button) -side left -fill x


        # Link up the widget and the -value option
        $itk_component(entry) configure -textvariable \
            [itcl::scope itk_option(-value)]
    }

    destructor {
        sourcenav::OptionTrace::deleteOptionTrace -variable -value \
            [itcl::scope itk_option]
    }

    private method select_file_cb {file} {
        global tcl_platform

        if {($tcl_platform(os)=="Windows 95") &({string length\
          $defaultextension} > 4)} {
            #Windows95 file select dialog has probably truncated the file\
              extension
            set file [file rootname ${file}]
            set file "${file}${defaultextension}"
        }
        
        if {${native}} {
            $this configure -value [file nativename $file]
        } else {
            $this configure -value ${file}
        }
    }

    private method select_file {} {

        if {$itk_option(-variable) != ""} {
	    global $itk_option(-variable)
	    upvar #0 $itk_option(-variable) var
            set inifile [file tail $var]