tools.tcl

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

            if {$directory && [file isdirectory $var]} {
                set inidir $var
            } else {
                set inidir [file dirname $var]
            }
        } else {
	    # Fixme: if the user is not using -variable
	    # there are other ways to initialize these:-
            set inifile ""
            set inidir ""
        }

        if {$directory} {
            Editor&::DirDialog [winfo toplevel $itk_component(entry)] -title\
               [get_indep String Open] -script [itcl::code ${this} select_file_cb] \
               -dir $inidir
        } else {
            Editor&::FileDialog [winfo toplevel $itk_component(entry)] -title\
              [get_indep String Open] -save_open ${save_open} -script\
              [itcl::code ${this} select_file_cb] \
              -defaultextension ${defaultextension} -extensions ${extensions}\
              -initialdir ${inidir} -initialfile ${inifile}
        }
    }

    public variable native 1
    public variable defaultextension ""
    public variable extensions ""
    public variable save_open "open"
    public variable anchor nw
    public variable buttonballoon [get_indep String ChooseINFO]

    # Used to set the entry widget value.
    itk_option define -value value Value ""

    # Used to set a variable that will be the entry widget value.
    itk_option define -variable variable Variable "" {
        sourcenav::OptionTrace::configureOptionTrace -variable -value \
            [itcl::scope itk_option]
    }

    public variable directory 0
}

#Choose colors
itcl::class ChooseColor& {
    inherit sourcenav::Dialog

    constructor {args} {
        global sn_options

        eval itk_initialize $args

	$this configure -modality application

        ${this} withdraw

        $this configure -title [get_indep String ChooseColor]

        # Ok/Apply/Cancel buttons can't be itk'd since they are
	# created in the sn_motif_buttons just now.

        sn_motif_buttons $itk_component(hull) bottom 0 [get_indep String ok]\
          [get_indep String Apply] [get_indep String cancel]
        $itk_component(hull).button_0 configure -command "${this} apply"
        $itk_component(hull).button_1 configure -command "${this} apply 0"
        $itk_component(hull).button_2 configure -command "$this deactivate 0"

        label $itk_component(hull).sample -text " "
        pack $itk_component(hull).sample -side top -fill x -expand y -pady 10 -padx 20

        if {[catch {$itk_component(hull).sample configure -bg $itk_option(-current)}]} {
             $itk_component(hull).sample configure -bg white
        }

        if {$itk_option(-current) == ""} {
            set current black
        }

        $this configure -current [winfo rgb $itk_component(hull).sample $itk_option(-current)]

        set bg [$itk_component(hull) cget -background]
        set i 0
        foreach clr {red green blue} {
            scale $itk_component(hull).${clr} -label ${clr} -from 0 -to 255 -showvalue y\
              -orient horizontal -variable [itcl::scope ${clr}] -bg ${bg} -command\
              "${this} view_color $clr"
            set ${clr} [format %i "0x[string range [format "%02x"\
              [lindex $itk_option(-current) ${i}]] 0 1]"]
            pack $itk_component(hull).${clr} -side top -fill x -expand y -padx 5 -pady 2
            incr i
        }

        #view current color
        view_color red 0

        #center window
        ${this} move_to_mouse
        ${this} take_focus
    }

    method view_color {clrname value} {
        $this configure -current [format "#%02x%02x%02x" $red $green $blue]
        $itk_component(hull).sample configure -bg $itk_option(-current)
    }

    method apply {{exit 1}} {

        if {${command} != ""} {
            eval ${command} [list $itk_option(-current)]
        }

        if {${exit}} {
	    deactivate 1
        }
    }

    private variable red ""
    private variable green ""
    private variable blue ""
    public variable command ""
    public variable variable ""
    itk_option define -current current Current "#000000"
}

#Choose Font
itcl::class ChooseFont& {
    inherit sourcenav::Dialog

    global sn_options

    constructor {args} {
        global sn_options
        global tcl_platform

        eval itk_initialize $args

        $this configure -modality application

        ${this} withdraw

        $this configure -title [get_indep String ChooseFont]

        #ok/apply/cancel buttons
        sn_motif_buttons $itk_component(hull) bottom 0 [get_indep String ok]\
          [get_indep String Apply] [get_indep String cancel]
        $itk_component(hull).button_0 configure -command "${this} apply "
        $itk_component(hull).button_1 configure -command "${this} apply 0"
        $itk_component(hull).button_2 configure -command "${this} deactivate 0"

        label $itk_component(hull).sample -text  [get_indep String Sample] -anchor c
        pack  $itk_component(hull).sample -side top -fill x -expand y -pady 10 -padx 20

        if {[catch {$itk_component(hull).sample configure -font $itk_option(-current)}]} {
            set current $sn_options(def,default-font)
             $itk_component(hull).sample configure -font $itk_option(-current)
        }

        set fntfr  $itk_component(hull).font
        frame ${fntfr}
        pack ${fntfr} -side top -fill x -padx 10 -pady 5

        set fntfr $itk_component(hull).font.name
        pack [frame ${fntfr}] -side top -fill x

        #font Family
        label ${fntfr}.famlbl -text [get_indep String Family] -anchor ne
        set fam ${fntfr}.fam
        Combo& ${fam} -width 12 -selectcommand "${this} view_font"
        #no family for windows
        if {$tcl_platform(platform) == "windows"} {
            ${fam} configure -contents [list "*"]
        } else {
            ${fam} configure -contents [list "*" Adobe Sony Schumacher B&H Bitstream Misc]
            pack ${fntfr}.famlbl -side left
            pack ${fam} -side left
        }

        #font name
        label ${fntfr}.namlbl -text [get_indep String FontName] -anchor ne
        pack ${fntfr}.namlbl -side left
        set nam ${fntfr}.nam
        Combo& ${nam} -width 22 -selectcommand "${this} view_font"
        if {$tcl_platform(platform) == "windows"} {
            ${nam} configure -contents [list "*" Arial {Comic Sans MS} Courier\
              {Courier New} Fixedsys Garamond {Lucida Console} {MS Sans Serif}\
              System {Times New Roman}]
        } else {
            ${nam} configure -contents [list "*" Courier Clean Fixed Lucida Terminal\
              Charter Helvetica {New Century Schoolbook} Times Utopia]
        }
        pack ${nam} -side left

        #font size
        label ${fntfr}.sizlbl -text [get_indep String FontSize] -anchor ne
        pack ${fntfr}.sizlbl -side left
        set siz ${fntfr}.siz
        Combo& ${siz} -width 3 -selectcommand "${this} view_font"
        ${siz} configure -contents [list "*" 8 10 11 12 13 14 15 16 18 20 22 24 28]
        pack ${siz} -side left

        set fntfr $itk_component(hull).font.checks
        pack [frame ${fntfr}] -side top -fill x -anchor c

        #Normal/Bold
        set bld ${fntfr}.bld
        checkbutton ${bld} -text [get_indep String FontBold]\
          -variable ${this}-bold -onvalue "bold" -offvalue "medium"\
          -underline ${underline} -command " ${this} view_font "

        pack ${bld} -side left -anchor c

        #Normal/Cursive
        set cursive ${fntfr}.cursive
        checkbutton ${cursive} -text [get_indep String FontCursive]\
          -variable ${this}-cursive -onvalue "o" -offvalue "r"\
          -underline ${underline} -command " ${this} view_font "
        pack ${cursive} -side left -anchor c

        disp_font $itk_option(-current)

        #view current color
        view_font $itk_option(-current)

        #center window
        ${this} centerOnScreen
        ${this} take_focus

        #vwait $variable
    }
    destructor {
        catch {itcl::delete object ${fam}}
        catch {itcl::delete object ${nam}}
        catch {itcl::delete object ${siz}}
        foreach v [::info globals "${this}-*"] {
            catch {uplevel #0 unset ${v}}
        }
    }

    method disp_font {fnt} {
        upvar #0 ${this}-bold bold
        upvar #0 ${this}-cursive cursive

        set fnt [split ${fnt} "-"]
        set len [llength ${fnt}]
        if {${len} > 8} {
            set family [lindex ${fnt} 1]
            set name [lindex ${fnt} 2]
            set sz [lindex ${fnt} 8]
            set bld [lindex ${fnt} 3]
            set crsv [lindex ${fnt} 4]
        } else {
            set name [lindex ${fnt} 0]
            set family ""
            set sz 120
            set bld ""
            set crsv ""
        }
        if {${name} == ""} {
            set name "Courier"
        }
        ${fam} selecttext ${family}
        ${nam} selecttext ${name}

        if {${sz} != "*" && [catch {set x [expr ${sz} + 0]}]} {
            set sz 120
        }
        if {${sz} != "*"} {
            set sz [expr ${sz} / 10]
        }
        ${siz} selecttext ${sz}

        set bold [string tolower ${bld}]
        set cursive [string tolower ${crsv}]
    }

    method view_font {{value ""}} {
        upvar #0 ${this}-bold bold
        upvar #0 ${this}-cursive cursive

        if {${bold} == ""} {
            set bold "medium"
        }
        if {${cursive} == ""} {
            set cursive "r"
        }
        set family [${fam} cget -entrytext]
        set name [${nam} cget -entrytext]
        set size [${siz} cget -entrytext]

        #add '0' to the font size
        if {${size} != "*"} {
            set size "${size}0"
        }

        set itk_option(-current) \
          "-${family}-${name}-${bold}-${cursive}-Normal--*-${size}-*-*-*-*-iso8859-1"
        if {[catch {$itk_component(hull).sample configure -font $itk_option(-current)}]} {
            set itk_option(-current) $sn_options(def,default-font)
            $itk_component(hull).sample configure -font $itk_option(-current)
            bell
        }
    }

    method apply {{exit 1}} {
        if {$itk_option(-command) != ""} {
            eval $itk_option(-command) [list $itk_option(-current)]
        }
        if {${exit}} {
            $this deactivate 1
        }
    }

    protected variable fam
    protected variable nam
    protected variable siz

    public variable underline -1

    itk_option define -command command Command ""

    itk_option define -current current Current $sn_options(def,default-font) {
        if {[winfo exists ${this}]} {
            disp_font $itk_option(-current)
            view_font
        }
    }
}

###################################################
##
## Color managment
##
###################################################
itcl::class Color& {
    inherit itk::Widget

    constructor {args} {
        global sn_path

        set unknown_bitmap [file join $sn_path(bitmapdir) undef.xbm]
        set plus_bitmap [file join $sn_path(bitmapdir) plus.xbm]
        set minus_bitmap [file join $sn_path(bitmapdir) minus.xbm]

        set cmbfr $itk_component(hull).cmbfr
        frame ${cmbfr}
        pack ${cmbfr} -side left -fill y

        #Schemes
        set combo ${cmbfr}.schemes
        Combo& ${combo} -selectcommand "${this} display_scheme"
        pack ${combo} -side top -fill x

        #Categories
        set tree ${cmbfr}.tree
        Tree ${tree} -indentwidth 20 -width 34 -plusimage plus_image\
          -minusimage minus_image -filter ""

        ${tree} treebind <ButtonRelease-1> "${this} display_value %x %y"
        ${tree} treebind <space> "%W selection clear 0 end
							%W selection set active
							${this} display_item
							break"
        ${tree} treebind <Return> [${tree} treebind <space>]
        pack ${tree} -side top -fill y -expand y
        set treew [${tree} tree]

        set fr $itk_component(hull).fr
        pack [frame ${fr}] -side right -fill both -expand y

        #sample for current setting
        set sample ${fr}.sample
        label ${sample} -text [get_indep String Sample] -anchor c -height 3
        pack ${sample} -fill x -side top -pady 30