pkg://mmucl-1.4.1-1.noarch.rpm:58618/usr/local/lib/mmucl/lib/tkconf.tcl  info  downloads

#################################################################
# tkconf.tcl - lib for configuring tk dynamically
#
# Copyright (C) 1997-1999 Mark Patton
#
# 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., 675 Mass Ave, Cambridge, MA 02139, USA.
#################################################################

namespace eval tkconf {
    array set type {
	"X Resource"  tkres
	"Tk Option"   tkopt
	"Tk Text Tag" tag
    }
}

# used in init file to build up tkconf

proc tkconf::add {type id args} {
    variable tkconf

    set tkconf($type,$id) $args
    return
}

# load in a file and set up all the Xresources

proc tkconf::init {file} {
    variable tkconf

    if {[file exists $file] && [catch {source $file} error]} {
	puts stderr "tkconf: loading $file: $error"
	return
    }

    foreach {id vallist} [array get tkconf tkres,*] {
	option add [lindex $vallist 0] [lindex $vallist 1]
    }
    
    return
}

proc tkconf::apply {} {
    variable tkconf

    foreach {id vallist} [array get tkconf] {
	conf $id $vallist
    }
    
    return
}

# add id to tkconf if configured without error
# FIXME: How do you determine if a Xresource is ok?

proc tkconf::conf {id vallist} {
    variable tkconf

    foreach {name val op1 op2} $vallist break
    
    switch -exact [lindex [split $id ,] 0] {
	tkopt {
	    if {[winfo exists $op1] && \
		    [tk_script [list $op1 configure -$name $val]]} {
		return
	    }
	} tag {
	    if {[winfo exists $op1] && \
		    [tk_script [list $op1 tag configure $name -$op2 $val]]} {
		return
	    }
	} tkres {
	    option add $name $val
	}
    }

    set tkconf($id) $vallist
    return
}

proc tkconf::tk_script {script} {
    if {[catch $script error]} {
	tk_messageBox -type ok -icon error -title "Tkconf Error" \
		-message $error
	return 1
    }
    
    return 0
}

proc tkconf::save {file} {
    variable tkconf

    set fd [open $file w+]
    
    foreach {id vallist} [array get tkconf] {
	puts $fd "add [split $id ,] $vallist"
    }

    flush $fd
    close $fd
    return
}

proc tkconf::dialog {} {
    variable tkconf
    variable type

    set w .tkconf

    if {[winfo exists $w]} {
        raise $w
        return
    }

    toplevel $w
    wm title $w "Tk Config"

    frame $w.type
    label $w.type.l -text Type
    listbox $w.type.list -yscroll [list $w.type.yscroll set] \
	    -exportselection 0
    scrollbar $w.type.yscroll -command [list $w.type.list yview]

    grid $w.type.l -row 0 -column 0
    grid $w.type.list -row 1 -column 0
    grid $w.type.yscroll -row 1 -column 1 -sticky ns

    foreach el [array names type] {
	$w.type.list insert end $el
    }

    frame $w.opt
    label $w.opt.l -text Option
    listbox $w.opt.list -yscroll [list $w.opt.yscroll set] \
	    -exportselection 0
    scrollbar $w.opt.yscroll -command [list $w.opt.list yview]
    #scrollbar $w.opt.xscroll -orient horizontal \
	    -command [list $w.opt.list xview]

    grid $w.opt.l -row 0 -column 0
    grid $w.opt.list -row 1 -column 0
    grid $w.opt.yscroll -row 1 -column 1 -sticky ns
    #grid $w.opt.xscroll -row 2 -column 0 -sticky ew
    
    frame $w.edit
    label $w.edit.l -text Value
    button $w.edit.apply -text Apply -command [list tkconf::_dialog_apply $w]
    button $w.edit.close -text Close -command [list destroy $w]
    entry $w.edit.entry

    pack $w.edit.l -side top
    pack $w.edit.entry
    pack $w.edit.apply
    pack $w.edit.close -side bottom
    
    pack $w.type $w.opt $w.edit -side left -expand 1 -fill both

    bind $w.edit.entry <Key-Return> [list tkconf::_dialog_apply $w]
    bind $w.opt.list <ButtonRelease-1> [list tkconf::_dialog_sel $w]
    bind $w.type.list <ButtonRelease-1> [list tkconf::_dialog_show $w]

    return $w
}

proc tkconf::_dialog_sel {w} {
    variable tkconf
    variable type

    set t [$w.type.list curselection]

    if {[string equal $t ""]} {
	return
    }

    set t $type([$w.type.list get $t])
    set i [$w.opt.list curselection]

    if {![string equal $i ""]} {
        set i [$w.opt.list get $i]

	$w.edit.entry delete 0 end
	$w.edit.entry insert 0 [lindex $tkconf($t,$i) 1]
    }

    return
}

proc tkconf::_dialog_show {w} {
    variable tkconf
    variable type

    set i [$w.type.list curselection]

    if {![string equal $i ""]} {
	set i [$w.type.list get $i]	
	set i $type($i)

	$w.opt.list delete 0 end
	foreach id [lsort [array names tkconf $i,*]] {
	    $w.opt.list insert end [lindex [split $id ,] 1]
	}
    }

    return
}

proc tkconf::_dialog_apply {w} {
    variable tkconf
    variable type

    set t [$w.type.list curselection]

    if {[string equal $t ""]} {
	return
    }

    set t $type([$w.type.list get $t])
    set i [$w.opt.list curselection]

    if {![string equal $i ""]} {
        set i [$w.opt.list get $i]	
	conf $t,$i [lreplace $tkconf($t,$i) 1 1 [$w.edit.entry get]]
    }
    
    return
}