Version 1 of textAttribSel

Updated 2005-10-13 09:51:35

# 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
 #
 #

 ##  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 } {

     eval 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

         set widgets(foo) foo  ;# coerce into an array

         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
     if { $options(-fontvariable) ne ""  } {
         unset initialfont
         upvar $options(-fontvariable) initialfont
     }
     if { $options(-fgvariable) ne ""  } {
         unset initialfg
         upvar $options(-fgvariable) initialfg
     }
     if { $options(-bgvariable) ne ""  } {
         unset initialbg
         upvar $options(-bgvariable) initialbg
     }


     # 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 { [lsearch [package names] tooltip] > -1 } {
         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 } \
         "eval ::textAttribSel::WidgetProc $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
     }
 }