Updated 2014-05-24 15:08:28 by pooryorick
# Copyright (c) 2005, Rüdiger Härtel
# All Rights Reservered
#
#
# This code is freely distributable without restriction, but is 
# provided as-is with no warranty expressed or implied. 
#
# Thanks to Bryan Oakley for his megawidget framework
# he provided with his combobox in pure tcl.
#
#
# This widget provides an interface for changing text attributes.
# If the tooltip package is available it uses it for the
# foreground and background images.
# The text for the tooltip is taken from the message catalog.
#
# Requirements:
#
#    dkffont.tcl       (http://people.man.ac.uk/~zzcgudf/tcl/mwidx.html#fontdlg)
#    tooltip                (only used if available, see tklib)
#
# Options:
#
#    -label                text for the label
#    -labelwidth        width of the label for alignment
#    -textwidth        textwidth for showing the font information
#    -fontvariable        reference for the font variable
#    -fgvariable        reference for the font variable
#    -bgvariable        reference for the font variable
#    -fgimage                image for the foreground button
#    -bgimage                image for the background button
#    -type                fontFgBg
#
# Commands:
#
#    cget {-font|-bg|-fg} get selected font, background or foreground
#
#

package require Tk
package provide textAttribSel 0.1

##  source dkffont.tcl

package require msgcat
msgcat::mcset de Font                        Zeichensatz
msgcat::mcset de "Select Foreground"        Vordergrundfarbe
msgcat::mcset de "Select Background"        Hintergrundfarbe


namespace eval textAttribSel {
    variable widgetCommands

    image create photo bg -data {
R0lGODlhIAAgAKEDAAAAALOzs/W3EP///yH5BAEKAAMALAAAAAAgACAAAAJd
nI+py+0Po5y0woCz3oHyn3ngJ45baYZTeq5sBsSy82bCfQN0HeD5XvMJdA1e
z0dkGIXJxRIJfDGjrGmRZ5UAhFxcE7Ltcr+PsBg6MZ9/6TVaK4vLZ5a6/Y7P
6ysFADs=
}

    image create photo fg -data {
R0lGODlhIAAgAKEDAAAAALOzs/W3EP///yH5BAEKAAMALAAAAAAgACAAAAJl
nI+py+0Po5y0QoCz3oACAYai2E3fiIKldKbjGrVuCF/z691kwPeOfAP0fA3g
TDgM/HS0pLLIVDmXUeSQyrQSGUaXlofVfZ9cjhkznTjX2wibTXmv4/Ikvd6G
4K+Wvv8PGChYUQAAOw==
}

}

# ::textAttribSel::textAttribSel --
#
#     This is the command that gets exported. It creates a new
#     textAttribSel widget.
#
# Arguments:
#
#     w        path of new widget to create
#     args     additional option/value pairs
#                (eg: -background white, etc.)
#
# Results:
#
#     It creates the widget and sets up all of the default bindings
#
# Returns:
#
#     The name of the newly create widget

proc textAttribSel::textAttribSel {w args} {
    Build $w {*}$args
}


# ::textAttribSel::Build --
#
#    This does all of the work necessary to create the basic
#    textAttribSel. 
#
# Arguments:
#
#    w        widget name
#    args     additional option/value pairs
#
# Results:
#
#    Creates a new widget with the given name. Also creates a new
#    namespace patterened after the widget name, as a child namespace
#    to ::textAttribSel
#
# Returns:
#
#    the name of the widget

proc textAttribSel::Build {w args} {
    namespace eval ::textAttribSel::$w {
        variable widgets
        # coerce into an array
        set widgets(foo) foo
        unset widgets(foo)
    }

    upvar ::textAttribSel::${w}::widgets widgets

    set options(-label) {} 
    set options(-labelwidth) 10
    set options(-textwidth) 20
    set options(-fontvariable) {} 
    set options(-fgvariable) {} 
    set options(-bgvariable) {} 
    set options(-fgimage) fg
    set options(-bgimage) bg
    set options(-type) fontFgBg

    # defaults, normally the values
    # are taken from the variables
    set initialfont "Helvetica 12"
    set initialfg black
    set initialbg white

    # error checking
    if {[llength $args] % 2 != 0} {
        error "wrong number of arguments"
    }

    # initialize variables
    foreach {arg value} $args {
        set options($arg) $value
    }

    # if variables already have values
    # take these as initial values for the widgets
    foreach {option varname} {
        -fontvariable initialfont -fgvariable initialfg -bgvariable initialbg} {
        unset $varname
        upvar $options($option) $varname
    }

    # build GUI
    frame $w -takefocus 0 -class textAttribSel
    set widgets(this) $w

    label $w.l -text $options(-label) -width $options(-labelwidth) \
            -anchor w -justify left
    text $w.t -height 1 -border 1 -width $options(-textwidth) \
            -background $initialbg -foreground $initialfg
    set widgets(text) $w.t
    button $w.font -text [msgcat::mc Font] -command [
        list textAttribSel::ShowFontSel $w $options(-fontvariable)]
    button $w.fg -relief flat -overrelief solid -border 1 \
            -image $options(-fgimage) -command [
                list textAttribSel::ShowColorSel $w fg $options(-fgvariable)]
    button $w.bg -relief flat -overrelief solid -border 1 \
            -image $options(-bgimage) -command [
                list textAttribSel::ShowColorSel $w bg $options(-bgvariable)]

    if {{tooltip} in [package names]} {
        package require tooltip
        package require msgcat
        tooltip::tooltip $w.fg [msgcat::mc "Select Foreground"]
        tooltip::tooltip $w.bg [msgcat::mc "Select Background"]
    }

    grid $w.l $w.t $w.font $w.fg $w.bg -padx 5 -sticky w        
    switch -- $options(-type) {
        fontFgBg {
            # standard case
        }
        fontFg {
            destroy $w.bg
        }
        fontBg {
            destroy $w.fg
        }
        default {
            error "unknown -type $option(-type)"
        }
    }

    $w.t insert 0.0 $initialfont
    $w.t configure -state disabled

    set widgets(frame) ::textAttribSel::${w}::$w
    rename $w ::$widgets(frame)
    proc ::$w {command args} \
        "::textAttribSel::WidgetProc [list $w] \$command {*}\$args"

    return $w
}

# ::textAttribSel::WidgetProc --
#
#    This gets uses as the widgetproc for an textAttribSel widget. 
#    Notice where the widget is created and you'll see that the
#    actual widget proc merely evals this proc with all of the
#    arguments intact.
#
# Arguments:
#
#    w         widget pathname
#    command   widget subcommand
#    args      additional arguments; varies with the subcommand
#
# Results:
#
#    Performs the requested widget command

proc ::textAttribSel::WidgetProc {w command args} {
    upvar ::textAttribSel::${w}::widgets widgets

    switch -- $command {
        cget {
            switch -- [lindex $args 0] {
                -font {
                   return [string map {\n {}} [$widgets(text) get 0.0 end]]
                }
                -bg -
                -background {
                   return [$widgets(text) cget -background]
                }
                -fg -
                -foreground {
                   return [$widgets(text) cget -foreground]
                }
            }
        }
    }
}

# ::textAttribSel::ShowFontSel --
#
#     Callback function that is called when the font button is
#     pressed.
#
# Arguments:
#
#    w         widget pathname
#    variable  assigned variable
#
# Results:
#
#    Opens the font selection dialogue.

proc textAttribSel::ShowFontSel {w variable} {
    upvar $variable font
    if {![info exists font]} {
        set font {Helvetica 12}
    }
    set font [dkf_chooseFont -apply {wm title .} -initialfont $font]

    if {$font eq {}} {
        return
    }

    $w.t configure -state normal
    $w.t delete 0.0 end
    $w.t insert 0.0 $font {}
    $w.t configure -state disabled

    if {$variable ne {}} {
        set $variable $font
    }
}

# ::textAttribSel::ShowColorSel --
#
#     Callback function that is called when the foreground
#     or background button is pressed.
#
# Arguments:
#
#    w         widget pathname
#    variable  assigned variable
#
# Results:
#
#    Opens the color selection dialogue.

proc textAttribSel::ShowColorSel {w type variable} {
    upvar $variable color
    if {![info exists color]} {
        switch $type {
            fg {
                set color black
            }
            bg {
                set color white
            }
        }
    }
    set color [tk_chooseColor -initialcolor $color -parent $w]

    if { $color eq {}} {
        return
    }

    switch $type {
        fg {
            $w.t configure -foreground $color
        }
        bg {
            $w.t configure -background $color
        }
    }
    if {$variable ne {}} {
        set $variable $color
    }
}

#
# some demo code
#

if {[info script] eq $argv0} {

    proc txtAttr {} {
        foreach item {.stdout .stderr .usr} {
           puts [$item cget -font]
           puts [$item cget -fg]
           puts [$item cget -bg]
        }
    }

    set fgimage [image create photo fg2 -data {
        R0lGODlhGAAYAMYDAAAAAHw4WbgkJDVSm7gnJrIrJ6cxJThUnDtXnqk1P3dW
        KUFcoEFcoYxGYb44OFFzLEhipE9lpMA/P05npzOMLzaNMlFqqbFNQlRtqoBg
        hYhhcJlhRT+TPEOVP7ZYTsBTV2Z5r8dZWMlaWk+cTFafUnGFuF+lXISYZoGT
        wISVwnOwcIeYw5SWunmzdqenp9uRkZqozceZpIy+iryhs4/AjdmbmLeovaOw
        0ZbDlJzCltuintWwp6/NqrPPreq+vsbO4+3IyMvfyc/kztnp2ODk79zr29/t
        3+Pv4uns9Ony6Ozv9fjr6+z07O/27/P0+fz8/fz9/P78/P///zVSmzVSmzVS
        mzVSmzVSmzVSmzVSmzVSmzVSmzVSmzVSmzVSmzVSmzVSmzVSmzVSmzVSmzVS
        mzVSmzVSmzVSmzVSmzVSmzVSmzVSmzVSmzVSmzVSmzVSmzVSmzVSmzVSmzVS
        mzVSmzVSmzVSmzVSmzVSmzVSmzVSmzVSmzVSmzVSmzVSmzVSmyH+FUNyZWF0
        ZWQgd2l0aCBUaGUgR0lNUAAh+QQBCgB/ACwAAAAAGAAYAAAH6YB/goOEhYaH
        iAOIhQCNjo+QAIgAUpWWUkoTJS9LlZKHlJZON08oAzYCQFBSn4ahlTAHPwMr
        Ig49Lawuu4yWPxMpIAMzAjojuQC7Lr1SRBYIMQMREiI5FEO6vISUShADLBIN
        GgQ1HSqeyr0YAwsfAjsGBTwURejag5QDAxkCISQKGzjIsJTsniAATxgMSCDg
        BAUaQa4RTLdNCpIAAi5QMNFEipFLBZdVjCJAwAMKOC5NNPgnlA8PFCowUWlP
        JD5LQjjkopnN5sFLSY7w7MkoktFGFA0pW8p0KaKmUJMWihp1kdWrWLNqNRQI
        ADs=
    }]

    set ST(line1,std-font) {Courier 12}
    set ST(line1,std-fg) yellow
    set ST(line1,std-bg) blue
    textAttribSel::textAttribSel .stdout -label Standard \
        -fontvariable ::ST(line1,std-font) \
        -fgvariable ::ST(line1,std-fg) \
        -bgvariable ::ST(line1,std-bg) \
        -fgimage $fgimage

    textAttribSel::textAttribSel .stderr -label Error -type fontFg
    textAttribSel::textAttribSel .usr    -label User -type fontBg
    pack .stdout
    pack .stderr
    pack .usr

    pack [button .b1 -text {Text Attributes} -command [list txtAttr]]

    if {$tcl_platform(platform) eq {windows}} {
        console show
    }
}