gEntry test

class gEntry {

    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

    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 } {
 bind $itk_component(hull) <Enter> [code $this enter]
 bind $itk_component(hull) <Leave> [code $this leave]

 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)
    }
}

body gEntry::enter { } {
    if {$balloon_queue != ""} {
 after cancel $balloon_queue
    }
    if {$itk_option(-balloonhelp) != ""} {
 set balloon_queue [after 750 [code $this balloon]]
    }
}

body gEntry::leave { } {
    if {$balloon_queue != ""} {
 after cancel $balloon_queue
    }
    set destroy_queue [after 100 {catch {destroy .balloon_help}}]
}

body gEntry::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}"
}

usual gEntry {
   #rename -disabledbackground -background background Background
   keep -textbackground -background
   keep -selectforeground -selectbackground
   keep -disabledbackground -disabledforeground
   keep -entryfont
   keep -padxy
}

# ###############################################################################
# FILEENTRY
# ###############################################################################

gEntry .c \
 -image ::img::distance16x16 \
 -balloonhelp "Crystal to detector distance" \
 -type real \
 -precision 2 \
 -width 6 \
 -justify right

pack .c