label.tcl

Linux下的MSN聊天程序源码

# ------------------------------------------------------------------------------
#  label.tcl
#  This file is part of Unifix BWidget Toolkit
#  $Id: label.tcl 3417 2004-12-03 00:31:24Z tjikkun $
# ------------------------------------------------------------------------------
#  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
}