initialize Widget in ini constructor {args} {ini} {body}
class Balloonwidget {
inherit itk::Widget
itk_option define -balloonhelp balloonHelp BalloonHelp ""
private variable balloon_queue ""
private variable destroy_queue ""
public method enter
public method leave
public method balloon
constructor { args } {
bind $itk_component(hull) <Enter> [code $this enter]
bind $itk_component(hull) <Leave> [code $this leave]
eval itk_initialize $args }
}
body Balloonwidget::enter { } {
if {$balloon_queue != ""} {
after cancel $balloon_queue
}
if {$itk_option(-balloonhelp) != ""} {
set balloon_queue [after 750 [code $this balloon]]
}
}
body Balloonwidget::leave { } {
if {$balloon_queue != ""} {
after cancel $balloon_queue
}
set destroy_queue [after 100 {catch {destroy .balloon_help}}]
}
body Balloonwidget::balloon { } {
set t .balloon_help
catch {destroy $t}
toplevel $t
wm overrideredirect $t 1
if {[tk windowingsystem] == "aqua"} {
#unsupported1 style $itk_component(hull) floating sideTitlebar
::tk::unsupported::MacWindowStyle style $t help none
}
label $t.l \
-text " $itk_option(-balloonhelp) " \
-relief solid \
-bd 2 \
-bg gold \
-fg #000000 \
-font font_b
pack $t.l -fill both
set x [expr [winfo pointerx $itk_component(hull)] + 8]
set y [expr [winfo pointery $itk_component(hull)] + 20]
if {[expr $x + [winfo reqwidth $t.l]] > [winfo screenwidth $t.l]} {
set x [expr [winfo screenwidth $t.l] - [winfo reqwidth $t.l] - 2]
}
if {[expr $y + [winfo reqheight $t.l]] > [winfo screenheight $t.l]} {
set y [expr $y - 20 - [winfo reqheight $t.l] - 2]
}
wm geometry $t +$x\+$y
#bind $t <Enter> [list [after cancel $destroy_queue]]
#bind $t <Leave> "catch {destroy .balloon_help}"
}
class gEntry {
inherit Balloonwidget
itk_option define -image image Image "" {
if {$itk_option(-image) != ""} {
$itk_component(icon) configure \
-image $itk_option(-image) \
-width [expr [image width $itk_option(-image)] + 4] \
-height [expr [image height $itk_option(-image)] + 4]
}
}
itk_option define -padxy padXY Pad 0 {
$itk_component(padding) configure -borderwidth $itk_option(-padxy)
}
itk_option define -disabledbackground disabledBackground Background "#dcdcdc"
itk_option define -disabledforeground disabledForeground DisabledForeground "#a9a9a9"
itk_option define -foreground foreground Foreground "#000000" {
if {$itk_option(-state) != "disabled"} {
$itk_component(entry) configure -foreground $itk_option(-foreground)
}
}
itk_option define -textbackground textBackground Background "#ffffff" {
if {$itk_option(-state) != "disabled"} {
$itk_component(entry) configure -background $itk_option(-textbackground)
$itk_component(icon) configure -background $itk_option(-textbackground)
}
$itk_component(frame) configure -background $itk_option(-textbackground)
}
itk_option define -entryfont entryFont Font font_e {
$itk_component(entry) configure -font $itk_option(-entryfont)
}
itk_option define -state state State "normal" {
if {$itk_option(-state) == "disabled"} {
$itk_component(entry) configure \
-state disabled \
-background $itk_option(-disabledbackground) \
-foreground $itk_option(-disabledforeground)
$itk_component(frame) configure \
-background $itk_option(-disabledbackground)
$itk_component(icon) configure \
-background $itk_option(-disabledbackground)
} else {
$itk_component(entry) configure \
-state normal \
-background $itk_option(-textbackground) \
-foreground $itk_option(-foreground)
$itk_component(frame) configure \
-background $itk_option(-textbackground)
$itk_component(icon) configure \
-background $itk_option(-textbackground)
}
}
itk_option define -type type Type "string"
itk_option define -defaultvalue defaultValue DefaultValue ""
itk_option define -precision precision Precision "2"
itk_option define -maximum maximum Maximum ""
itk_option define -minimum minimum Minimum ""
itk_option define -allowblank allowBlank AllowBlank "1"
itk_option define -linkcommand linkCommand Command ""
itk_option define -editcommand editCommand Command ""
itk_option define -command command Command ""
public method validate
public method focusOut
public method update
public method query
public method keystroke
constructor { args } {
itk_component add padding {
frame $itk_interior.p \
-relief flat \
}
pack $itk_component(padding) -fill x
itk_component add frame {
frame $itk_interior.p.f \
-borderwidth 2 \
-relief sunken
} {
usual
keep -borderwidth
keep -relief
}
pack $itk_component(frame) -fill x
itk_component add icon {
label $itk_interior.p.f.icon \
-anchor c \
-padx 0 \
-pady 0 \
-bd 0
}
pack $itk_component(icon) -side left
itk_component add entry {
entry $itk_interior.p.f.entry \
-relief flat \
-borderwidth 0 \
-highlightthickness 0 \
-selectborderwidth 0 \
-validate all \
-validatecommand [code $this validate %V %P]
} {
keep -insertbackground -insertborderwidth -insertwidth
keep -insertontime -insertofftime
keep -selectbackground -selectforeground
keep -textvariable
keep -width
keep -justify
keep -show
}
pack $itk_component(entry) -side right -fill x -expand true
bind $itk_component(entry) <FocusOut> [code $this focusOut]
bind $itk_component(entry) <Return> [code $this focusOut]
bind $itk_component(entry) <KeyPress> [code $this keystroke]
eval itk_initialize $args
}
}
body gEntry::query { } {
return [$itk_component(entry) get]
}
body gEntry::update { a_value } {
if {[validate "focusout" $a_value]} {
$itk_component(entry) configure -state normal
$itk_component(entry) delete 0 end
$itk_component(entry) insert 0 $a_value
$itk_component(entry) configure -state $itk_option(-state)
focusOut -nolink
}
}
body gEntry::validate { reason new_string } {
switch -- $reason {
key {
switch -- $itk_option(-type) {
real {
if {[regexp -- {^-?\d*\.?\d*$} $new_string]} {
return 1
} else {
bell
return 0
}
}
int {
if {[regexp -- {^-?\d*$} $new_string]} {
return 1
} else {
bell
return 0
}
}
default {
return 1
}
}
}
forced {
# Trust myself to only force it to accept well-formed values
return 1
}
focusout {
switch -- $itk_option(-type) {
real {
if {[regexp -- {^-?\.?$} $new_string]} {set new_string ""}
if {$new_string == ""} {
if {$itk_option(-allowblank)} {
return 1
} elseif {$itk_option(-defaultvalue) != ""} {
set new_string $itk_option(-defaultvalue)
} else {
set new_string 0
}
}
if {$itk_option(-maximum) != ""} {
if {$new_string > $itk_option(-maximum)} {
set new_string $itk_option(-maximum)
}
}
if {$itk_option(-minimum) != ""} {
if {$new_string < $itk_option(-minimum)} {
set new_string $itk_option(-minimum)
}
}
$itk_component(entry) delete 0 end
$itk_component(entry) insert 0 [format %.$itk_option(-precision)f $new_string]
# Need to turn valistaion back on, as setting the entry content
# here will have turned it off.
after idle [list $itk_component(entry) configure -validate all]
return 1
}
int {
if {[regexp -- {^-?$} $new_string]} {set new_string ""}
if {$new_string == ""} {
if {$itk_option(-allowblank)} {
return 1
} elseif {$itk_option(-defaultvalue) != ""} {
set new_string $itk_option(-defaultvalue)
} else {
set new_string 0
}
}
if {$itk_option(-maximum) != ""} {
if {$new_string > $itk_option(-maximum)} {
set new_string $itk_option(-maximum)
}
}
if {$itk_option(-minimum) != ""} {
if {$new_string < $itk_option(-minimum)} {
set new_string $itk_option(-minimum)
}
}
$itk_component(entry) delete 0 end
$itk_component(entry) insert 0 $new_string
# Need to turn validation back on, as setting the entry content
# here will have turned it off.
after idle [list $itk_component(entry) configure -validate all]
return 1
}
default {
return 1
}
}
}
default {
return 1
}
}
}
body gEntry::focusOut { { a_link "-link" } } {
$itk_component(entry) selection clear
if {$itk_option(-command) != ""} {
uplevel #0 [list $itk_option(-command) "[$itk_component(entry) get]"]
}
if { $a_link != "-nolink" } {
if {$itk_option(-linkcommand) != ""} {
uplevel #0 $itk_option(-linkcommand)
}
}
}
body gEntry::keystroke { } {
if {$itk_option(-editcommand) != ""} {
uplevel #0 $itk_option(-editcommand)
}
}
usual gEntry {
#rename -disabledbackground -background background Background
keep -textbackground -background
keep -selectforeground -selectbackground
keep -disabledbackground -disabledforeground
keep -entryfont
keep -padxy
}
class testt {
inherit gEntry
constructor { args } {
eval gEntry::constructor $args
} {
eval itk_initialize $args
}
}
testt .c \
-image ::img::distance16x16 \
-balloonhelp "Crystal to detector distance" \
-type real \
-precision 2 \
-width 6 \
-justify right
pack .c
