--- /dev/null
+# ------------------------------------------------------------------------------
+# label.tcl
+# This file is part of Unifix BWidget Toolkit
+# $Id: label.tcl,v 1.1.1.1 2004/11/21 03:02:54 eric_mcdonald Exp $
+# ------------------------------------------------------------------------------
+# Index of commands:
+# - Label::create
+# - Label::configure
+# - Label::cget
+# - Label::setfocus
+# - Label::_drag_cmd
+# - Label::_drop_cmd
+# - Label::_over_cmd
+# ------------------------------------------------------------------------------
+
+namespace eval Label {
+ Widget::define Label label DragSite DropSite DynamicHelp
+
+ Widget::tkinclude Label label .l \
+ remove { -foreground -text -textvariable -underline }
+
+ Widget::declare Label {
+ {-name String "" 0}
+ {-text String "" 0}
+ {-textvariable String "" 0}
+ {-underline Int -1 0 "%d >= -1"}
+ {-focus String "" 0}
+ {-foreground TkResource "" 0 label}
+ {-disabledforeground TkResource "" 0 button}
+ {-state Enum normal 0 {normal disabled}}
+
+ {-fg Synonym -foreground}
+ }
+
+ DynamicHelp::include Label balloon
+ DragSite::include Label "" 1
+ DropSite::include Label {
+ TEXT {move {}}
+ IMAGE {move {}}
+ BITMAP {move {}}
+ FGCOLOR {move {}}
+ BGCOLOR {move {}}
+ COLOR {move {}}
+ }
+
+ Widget::syncoptions Label "" .l {-text {} -underline {}}
+
+ bind BwLabel <FocusIn> [list Label::setfocus %W]
+ bind BwLabel <Destroy> [list Label::_destroy %W]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Label::create
+# ------------------------------------------------------------------------------
+proc Label::create { path args } {
+ array set maps [list Label {} .l {}]
+ array set maps [Widget::parseArgs Label $args]
+ frame $path -class Label -borderwidth 0 -highlightthickness 0 -relief flat
+ Widget::initFromODB Label $path $maps(Label)
+
+ eval [list label $path.l] $maps(.l)
+
+ if { [Widget::cget $path -state] == "normal" } {
+ set fg [Widget::cget $path -foreground]
+ } else {
+ set fg [Widget::cget $path -disabledforeground]
+ }
+
+ set var [Widget::cget $path -textvariable]
+ if { $var == "" &&
+ [Widget::cget $path -image] == "" &&
+ [Widget::cget $path -bitmap] == ""} {
+ set desc [BWidget::getname [Widget::cget $path -name]]
+ if { $desc != "" } {
+ set text [lindex $desc 0]
+ set under [lindex $desc 1]
+ } else {
+ set text [Widget::cget $path -text]
+ set under [Widget::cget $path -underline]
+ }
+ } else {
+ set under -1
+ set text ""
+ }
+
+ $path.l configure -text $text -textvariable $var \
+ -underline $under -foreground $fg
+
+ set accel [string tolower [string index $text $under]]
+ if { $accel != "" } {
+ bind [winfo toplevel $path] <Alt-$accel> "Label::setfocus $path"
+ }
+
+ bindtags $path [list BwLabel [winfo toplevel $path] all]
+ bindtags $path.l [list $path.l $path Label [winfo toplevel $path] all]
+ pack $path.l -expand yes -fill both
+
+ set dragendcmd [Widget::cget $path -dragendcmd]
+ DragSite::setdrag $path $path.l Label::_init_drag_cmd $dragendcmd 1
+ DropSite::setdrop $path $path.l Label::_over_cmd Label::_drop_cmd 1
+ DynamicHelp::sethelp $path $path.l 1
+
+ return [Widget::create Label $path]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Label::configure
+# ------------------------------------------------------------------------------
+proc Label::configure { path args } {
+ set oldunder [$path.l cget -underline]
+ if { $oldunder != -1 } {
+ set oldaccel [string tolower [string index [$path.l cget -text] $oldunder]]
+ } else {
+ set oldaccel ""
+ }
+ set res [Widget::configure $path $args]
+
+ set cfg [Widget::hasChanged $path -foreground fg]
+ set cdfg [Widget::hasChanged $path -disabledforeground dfg]
+ set cst [Widget::hasChanged $path -state state]
+
+ if { $cst || $cfg || $cdfg } {
+ if { $state == "normal" } {
+ $path.l configure -fg $fg
+ } else {
+ $path.l configure -fg $dfg
+ }
+ }
+
+ set cv [Widget::hasChanged $path -textvariable var]
+ set cb [Widget::hasChanged $path -image img]
+ set ci [Widget::hasChanged $path -bitmap bmp]
+ set cn [Widget::hasChanged $path -name name]
+ set ct [Widget::hasChanged $path -text text]
+ set cu [Widget::hasChanged $path -underline under]
+
+ if { $cv || $cb || $ci || $cn || $ct || $cu } {
+ if { $var == "" && $img == "" && $bmp == "" } {
+ set desc [BWidget::getname $name]
+ if { $desc != "" } {
+ set text [lindex $desc 0]
+ set under [lindex $desc 1]
+ }
+ } else {
+ set under -1
+ set text ""
+ }
+ set top [winfo toplevel $path]
+ if { $oldaccel != "" } {
+ bind $top <Alt-$oldaccel> {}
+ }
+ set accel [string tolower [string index $text $under]]
+ if { $accel != "" } {
+ bind $top <Alt-$accel> [list Label::setfocus $path]
+ }
+ $path.l configure -text $text -underline $under -textvariable $var
+ }
+
+ set force [Widget::hasChanged $path -dragendcmd dragend]
+ DragSite::setdrag $path $path.l Label::_init_drag_cmd $dragend $force
+ DropSite::setdrop $path $path.l Label::_over_cmd Label::_drop_cmd
+ DynamicHelp::sethelp $path $path.l
+
+ return $res
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Label::cget
+# ------------------------------------------------------------------------------
+proc Label::cget { path option } {
+ return [Widget::cget $path $option]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Label::setfocus
+# ------------------------------------------------------------------------------
+proc Label::setfocus { path } {
+ if { [string equal [Widget::cget $path -state] "normal"] } {
+ set w [Widget::cget $path -focus]
+ if { [winfo exists $w] && [Widget::focusOK $w] } {
+ focus $w
+ }
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Label::_init_drag_cmd
+# ------------------------------------------------------------------------------
+proc Label::_init_drag_cmd { path X Y top } {
+ set path [winfo parent $path]
+ if { [set cmd [Widget::cget $path -draginitcmd]] != "" } {
+ return [uplevel \#0 $cmd [list $path $X $Y $top]]
+ }
+ if { [set data [$path.l cget -image]] != "" } {
+ set type "IMAGE"
+ pack [label $top.l -image $data]
+ } elseif { [set data [$path.l cget -bitmap]] != "" } {
+ set type "BITMAP"
+ pack [label $top.l -bitmap $data]
+ } else {
+ set data [$path.l cget -text]
+ set type "TEXT"
+ }
+ set usertype [Widget::getoption $path -dragtype]
+ if { $usertype != "" } {
+ set type $usertype
+ }
+ return [list $type {copy} $data]
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Label::_drop_cmd
+# ------------------------------------------------------------------------------
+proc Label::_drop_cmd { path source X Y op type data } {
+ set path [winfo parent $path]
+ if { [set cmd [Widget::cget $path -dropcmd]] != "" } {
+ return [uplevel \#0 $cmd [list $path $source $X $Y $op $type $data]]
+ }
+ if { $type == "COLOR" || $type == "FGCOLOR" } {
+ configure $path -foreground $data
+ } elseif { $type == "BGCOLOR" } {
+ configure $path -background $data
+ } else {
+ set text ""
+ set image ""
+ set bitmap ""
+ switch -- $type {
+ IMAGE {set image $data}
+ BITMAP {set bitmap $data}
+ default {
+ set text $data
+ if { [set var [$path.l cget -textvariable]] != "" } {
+ configure $path -image "" -bitmap ""
+ GlobalVar::setvar $var $data
+ return
+ }
+ }
+ }
+ configure $path -text $text -image $image -bitmap $bitmap
+ }
+ return 1
+}
+
+
+# ------------------------------------------------------------------------------
+# Command Label::_over_cmd
+# ------------------------------------------------------------------------------
+proc Label::_over_cmd { path source event X Y op type data } {
+ set path [winfo parent $path]
+ if { [set cmd [Widget::cget $path -dropovercmd]] != "" } {
+ return [uplevel \#0 $cmd [list $path $source $event $X $Y $op $type $data]]
+ }
+ if { [Widget::getoption $path -state] == "normal" ||
+ $type == "COLOR" || $type == "FGCOLOR" || $type == "BGCOLOR" } {
+ DropSite::setcursor based_arrow_down
+ return 1
+ }
+ DropSite::setcursor dot
+ return 0
+}
+
+
+proc Label::_destroy { path } {
+ Widget::destroy $path
+}
projects / xconq / blobdiff