# ipentry.tcl -- # # An entry widget for IP addresses. # # Copyright (c) 2003-2008 Aaron Faupell # Copyright (c) 2008 Pat Thoyts # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: ipentry.tcl,v 1.19 2009/01/21 07:10:03 afaupell Exp $ package require Tk package provide ipentry 0.3 namespace eval ::ipentry { namespace export ipentry ipentry6 # copy all the bindings from Entry class to our own IPEntrybindtag class foreach x [bind Entry] { bind IPEntrybindtag $x [bind Entry $x] } # then replace certain keys we are interested in with our own bind IPEntrybindtag {::ipentry::keypress %W %K} bind IPEntrybindtag {::ipentry::backspace %W} bind IPEntrybindtag {::ipentry::dot %W} bind IPEntrybindtag {::ipentry::arrow %W %K} bind IPEntrybindtag {::ipentry::arrow %W %K} bind IPEntrybindtag {::ipentry::FocusIn %W} bind IPEntrybindtag {::ipentry::FocusOut %W} bind IPEntrybindtag <> {::ipentry::Paste %W CLIPBOARD} bind IPEntrybindtag <> {::ipentry::Paste %W PRIMARY} # copy all the bindings from IPEntrybindtag foreach x [bind IPEntrybindtag] { bind IPEntrybindtag6 $x [bind IPEntrybindtag $x] } # and replace certain keys with ip6 bindings bind IPEntrybindtag6 {::ipentry::keypress %W %K 6} bind IPEntrybindtag6 {::ipentry::dot %W} bind IPEntrybindtag6 {} #if {[package vsatisfies [package provide Tk] 8.5]} { # ttk::style layout IPEntryFrame { # Entry.field -sticky news -border 1 -children { # IPEntryFrame.padding -sticky news # } # } # bind [winfo class .] <> \ # [list +ttk::style layout IPEntryFrame \ # [ttk::style layout IPEntryFrame]] # } } # ipentry -- # # main entry point - construct a new ipentry widget # # ARGS: # w path name of widget to create # # see ::ipentry::configure for args # # RETURNS: # the widget path name # proc ::ipentry::ipentry {w args} { upvar #0 [namespace current]::widget_$w state #set state(themed) [package vsatisfies [package provide Tk] 8.5] set state(themed) 0 foreach {name val} $args { if {$name eq "-themed"} { set state(themed) $val } } if {$state(themed)} { ttk::frame $w -style IPEntryFrame -class IPEntry -takefocus 0 } else { frame $w -relief sunken -class IPEntry;#-padx 5 } foreach x {0 1 2 3} y {d1 d2 d3 d4} { #if {$state(themed)} { # ttk::entry $w.$x -width 3 -justify center # ttk::label $w.$y -text . #} entry $w.$x -borderwidth 0 -width 3 -highlightthickness 0 \ -justify center -takefocus 0 label $w.$y -borderwidth 0 -font [$w.$x cget -font] -width 1 -text . \ -justify center -cursor [$w.$x cget -cursor] \ -background [$w.$x cget -background] \ -disabledforeground [$w.$x cget -disabledforeground] pack $w.$x $w.$y -side left bindtags $w.$x [list $w.$x IPEntrybindtag . all] bind $w.$y {::ipentry::dotclick %W %x} } destroy $w.d4 $w.0 configure -takefocus 1 if {$state(themed)} { pack configure $w.0 -padx {1 0} -pady 1 pack configure $w.3 -padx {0 1} -pady 1 -fill x -expand 1 $w.3 configure -justify left } else { $w configure -borderwidth [lindex [$w.0 configure -bd] 3] #-background [$w.0 cget -bg] } rename ::$w ::ipentry::_$w # redirect the widget name command to the widgetCommand dispatcher interp alias {} ::$w {} ::ipentry::widgetCommand $w bind $w [list ::ipentry::destroyWidget $w] if {[llength $args] > 0} { eval [list $w configure] $args } return $w } # ipentry -- # # main entry point - construct a new ipentry6 widget # # ARGS: # w path name of widget to create # # see ::ipentry::configure for args # # RETURNS: # the widget path name # proc ::ipentry::ipentry6 {w args} { upvar #0 [namespace current]::widget_$w state #set state(themed) [package vsatisfies [package provide Tk] 8.5] set state(themed) 0 foreach {name val} $args { if {$name eq "-themed"} { set state(themed) $val } } if {$state(themed)} { ttk::frame $w -style IPEntryFrame -class IPEntry -takefocus 0 } else { frame $w -relief sunken -class IPEntry;#-padx 5 } foreach x {0 1 2 3 4 5 6 7} y {d1 d2 d3 d4 d5 d6 d7 d8} { entry $w.$x -borderwidth 0 -width 4 -highlightthickness 0 \ -justify center -takefocus 0 label $w.$y -borderwidth 0 -font [$w.$x cget -font] -width 1 -text : \ -justify center -cursor [$w.$x cget -cursor] \ -background [$w.$x cget -background] \ -disabledforeground [$w.$x cget -disabledforeground] pack $w.$x $w.$y -side left bindtags $w.$x [list $w.$x IPEntrybindtag6 . all] bind $w.$y {::ipentry::dotclick %W %x} } destroy $w.d8 $w.0 configure -takefocus 1 if {$state(themed)} { pack configure $w.0 -padx {1 0} -pady 1 pack configure $w.7 -padx {0 1} -pady 1 -fill x -expand 1 $w.7 configure -justify left } else { $w configure -borderwidth [lindex [$w.0 configure -bd] 3] #-background [$w.0 cget -bg] } rename ::$w ::ipentry::_$w # redirect the widget name command to the widgetCommand dispatcher interp alias {} ::$w {} ::ipentry::widgetCommand6 $w bind $w [list ::ipentry::destroyWidget $w] if {[llength $args] > 0} { eval [list $w configure] $args } return $w } # keypress -- # # called every time a key is pressed in an ipentry widget # used by both ipentry and ipentry6 # # ARGS: # w window argument (%W) from the event binding # key the keysym (%K) from the event # type empty string or "6" depending on the type of ipentry # # RETURNS: # nothing # proc ::ipentry::keypress {w key {type {}}} { if {![validate$type $w $key]} { return } # sel.first and sel.last throw an error if the selection isnt in $w catch { set insert [$w index insert] # if a key is pressed while there is a selection then delete the # selected chars if {([$w index sel.first] <= $insert) && ([$w index sel.last] >= $insert)} { $w delete sel.first sel.last } } $w insert insert $key ::ipentry::updateTextvar $w } # backspace -- # # called when the Backspace key is pressed in an ipentry widget # used by both ipentry and ipentry6 # # try to act like a normal backspace except if the cursor is at index 0 # of one entry we need to move to the end of the preceding entry # # ARGS: # w window argument (%W) from the event binding # # RETURNS: # nothing # proc ::ipentry::backspace {w} { if {[$w selection present]} { $w delete sel.first sel.last } else { if {[$w index insert] == 0} { set w [skip $w prev] } $w delete [expr {[$w index insert] - 1}] } ::ipentry::updateTextvar $w } # dot -- # # called when the dot (Period) key is pressed in an ipentry widget # used by both ipentry and ipentry6 # # treat the current entry as done and move to the next entry field # # ARGS: # w window argument (%W) from the event binding # # RETURNS: # nothing # proc ::ipentry::dot {w} { if {[string length [$w get]] > 0} { skip $w next 1 } ::ipentry::updateTextvar $w } # FocusIn -- # # called when the focus enters any of the child widgets of an ipentry # used by both ipentry and ipentry6 # # clear the selection of all child widgets other than the one with focus # # ARGS: # w window argument (%W) from the event binding # # RETURNS: # nothing # proc ::ipentry::FocusIn {w} { set p [winfo parent $w] foreach x {0 1 2 3 4 5 6 7} { if {![winfo exists $p.$x]} { break } if {"$p.$x" != $w} { $p.$x selection clear } } } # FocusOut -- # # called when the focus leaves any of the child widgets of an ipentry # used by both ipentry and ipentry6 # # dont allow a 0 in the first quad # # ARGS: # w window argument (%W) from the event binding # # RETURNS: # nothing # proc ::ipentry::FocusOut {w} { set s [$w get] if {[string match {*.0} $w] && $s != "" && $s < 1} { $w delete 0 end $w insert end 1 ::ipentry::updateTextvar $w } # trim off leading zeros if {[string length $s] > 1} { set n [string trimleft $s 0] if {$n eq ""} { set n 0 } if {![string equal $n $s]} { $w delete 0 end $w insert end $n } } } # Paste -- # # called from the <> virtual event # used by ipentry only # # clear the selection of all child widgets other than the one with focus # # ARGS: # w window argument (%W) from the event binding # sel one of CLIPBOARD or PRIMARY # # RETURNS: # nothing # proc ::ipentry::Paste {w sel} { if {[catch {::tk::GetSelection $w $sel} paste]} { return } $w delete 0 end foreach char [split $paste {}] { # ignore everything except dots and digits if {![string match {[0123456789.]} $char]} { continue } if {$char != "."} { $w insert end $char } # if value is over 255 truncate it if {[$w get] > 255} { $w delete 0 end $w insert 0 255 } # if char is a . then get the index of the current entry # and update $w to point to the next entry if {$char == "."} { set n [string index $w end] if { $n >= 3 } { return } set w [string trimright $w "0123"][expr {$n + 1}] $w delete 0 end continue } } ::ipentry::updateTextvar $w } # Paste6 -- # # called from the <> virtual event # used by both ipentry6 only # # clear the selection of all child widgets other than the one with focus # # ARGS: # w window argument (%W) from the event binding # sel one of CLIPBOARD or PRIMARY # # RETURNS: # nothing # proc ::ipentry::Paste6 {w sel} { if {[catch {::tk::GetSelection $w $sel} paste]} { return } $w delete 0 end foreach char [split $paste {}] { # ignore everything except colons and hex digits if {![string match {[0123456789abcdefABCDEF:]} $char]} { continue } if {$char != ":"} { $w insert end $char } # if char is a : then get the index of the current entry # and update $w to point to the next entry if {$char == ":"} { set n [string index $w end] if { $n >= 7 } { return } set w [string trimright $w "01234567"][expr {$n + 1}] $w delete 0 end continue } } ::ipentry::updateTextvar $w } # dotclick -- # # called when mouse button 1 is clicked on any of the label widgets # used by both ipentry and ipentry6 # # decide which side of the dot was clicked and put the focus and cursor # in the correct entry # # ARGS: # w window argument (%W) from the event binding # # RETURNS: # nothing # proc ::ipentry::dotclick {w x} { if {$x > ([winfo width $w] / 2)} { set w [winfo parent $w].[string index $w end] focus $w $w icursor 0 } else { set w [winfo parent $w].[expr {[string index $w end] - 1}] focus $w $w icursor end } } # arrow -- # # called when the left or right arrow keys are pressed in an ipentry # used by both ipentry and ipentry6 # # ARGS: # w window argument (%W) from the event binding # key one of Left or Right # # RETURNS: # nothing # proc ::ipentry::arrow {w key} { set i [$w index insert] set l [string length [$w get]] # move the icursor +1 or -1 position $w icursor [expr $i [string map {Right + Left -} $key] 1] $w selection clear # if we are moving right and the cursor is at the end, or the entry is empty if {$key == "Right" && ($i == $l || $l == 0)} { skip $w next } elseif {$key == "Left" && $i == 0} { skip $w prev } } # validate -- # # called by keypress to validate the input # used by ipentry only # # ARGS: # w window argument (%W) from the event binding # key the key pressed # # RETURNS: # a boolean indicating if the key is valid or not # proc ::ipentry::validate {w key} { if {![string match {[0123456789]} $key]} { return 0 } set curval [$w get] set insert [$w index insert] # dont allow more than a single 0 to be entered if {$curval == "0" && $key == "0"} { return 0 } if {[string length $curval] == 2} { set curval [join [linsert [split $curval {}] $insert $key] {}] if {$curval > 255} { $w delete 0 end $w insert 0 255 $w selection range 0 end ::ipentry::updateTextvar $w return 0 } elseif {$insert == 2} { skip $w next 1 } return 1 } if {[string length $curval] >= 3 && ![$w selection present]} { if {$insert == 3} { skip $w next 1 } return 0 } return 1 } # validate6 -- # # called by keypress to validate the input # used by ipentry6 only # # ARGS: # w window argument (%W) from the event binding # key the key pressed # # RETURNS: # a boolean indicating if the key is valid or not # proc ::ipentry::validate6 {w key} { if {![string is xdigit $key]} { return 0 } set curval 0x[$w get] set insert [$w index insert] # dont allow more than a single 0 to be entered if {$curval == "0" && $key == "0"} { return 0 } if {[string length $curval] == 5} { set curval [join [linsert [split $curval {}] $insert $key] {}] if {$insert == 3} { skip $w next 1 } return 1 } if {[string length $curval] >= 6 && ![$w selection present]} { if {$insert == 4} { skip $w next 1 } return 0 } return 1 } # skip -- # # move the cursor to the previous or next entry widget # used by both ipentry and ipentry6 # # ARGS: # w name of the current entry widget # dir direction to move, one of next or prev # sel boolean indicating whether to select the digits in the next entry # # RETURNS: # the name of the widget with focus # proc ::ipentry::skip {w dir {sel 0}} { set n [string index $w end] if {$dir == "next"} { set next [string trimright $w "012345678"][expr {$n + 1}] if { ![winfo exists $next] } { return $w } focus $next if {$sel} { $next icursor 0 $next selection range 0 end } return $next } else { if { $n <= 0 } { return $w } set prev [string trimright $w "012345678"][expr {$n - 1}] focus $prev $prev icursor end return $prev } } # _foreach -- # # utility for the widget configure command # # perform a command on every subwidget of an ipentry frame # # ARGS: # w name of the ipentry frame # cmd command to perform # type one of empty, "entry", or "dot" # # RETURNS: # nothing # proc ::ipentry::_foreach {w cmd {type {}}} { if {$type == "" || $type == "entry"} { foreach x {0 1 2 3 4 5 6 7} { if {![winfo exists $w.$x]} { break } eval [list $w.$x] $cmd } } if {$type == "" || $type == "dot"} { foreach x {d1 d2 d3 d4 d5 d6 d7} { if {![winfo exists $w.$x]} { break } eval [list $w.$x] $cmd } } } # cget -- # # handle the widgetName cget subcommand # used by both ipentry and ipentry6 # # ARGS: # w name of the ipentry widget # cmd name of a configuration option # # RETURNS: # the value of the requested option # proc ::ipentry::cget {w cmd} { upvar #0 [namespace current]::widget_$w state switch -exact -- $cmd { -bd - -borderwidth - -relief { # for bd and relief return the value from the container frame if {!$state(themed)} { return [::ipentry::_$w cget $cmd] } } -textvariable { if {[info exists ::ipentry::textvars($w)]} { return $::ipentry::textvars($w) } return {} } -themed { return $state(themed) } -takefocus { return 0 } default { # for all other commands return the value from the first entry return [$w.0 cget $cmd] } } } # configure -- # # handle the widgetName configure subcommand # used by both ipentry and ipentry6 # # ARGS: # w name of the ipentry widget # args name/value pairs of configuration options # # RETURNS: # nothing # proc ::ipentry::configure {w args} { upvar #0 [namespace current]::widget_$w Priv while {[set cmd [lindex $args 0]] != ""} { switch -exact -- $cmd { -state { set state [lindex $args 1] if {$state == "disabled"} { _foreach $w [list configure -state disabled] if {[set dbg [$w.0 cget -disabledbackground]] == ""} { set dbg [$w.0 cget -bg] } _foreach $w [list configure -bg $dbg] dot if {$Priv(themed)} { ::ipentry::_$w state disabled } else { ::ipentry::_$w configure -background $dbg } } elseif {$state == "normal"} { _foreach $w [list configure -state normal] _foreach $w [list configure -bg [$w.0 cget -bg]] dot if {$Priv(themed)} { ::ipentry::_$w state {!readonly !disabled} } else { ::ipentry::_$w configure -background [$w.0 cget -bg] } } elseif {$state == "readonly"} { _foreach $w [list configure -state readonly] entry if {[set robg [$w.0 cget -readonlybackground]] == ""} { set robg [$w.0 cget -bg] } _foreach $w [list configure -bg $robg] dot if {$Priv(themed)} { ::ipentry::_$w state !readonly } else { ::ipentry::_$w configure -background $robg } } set args [lrange $args 2 end] } -bg - -background { set bg [lindex $args 1] _foreach $w [list configure -background $bg] if {!$Priv(themed)} { ::ipentry::_$w configure -background $bg } set args [lrange $args 2 end] } -disabledforeground { _foreach $w [list configure -disabledforeground [lindex $args 1]] set args [lrange $args 2 end] } -font - -fg - -foreground { _foreach $w [list configure $cmd [lindex $args 1]] set args [lrange $args 2 end] } -bd - -borderwidth - -relief - -highlightcolor - -highlightbackground - -highlightthickness { _$w configure $cmd [lindex $args 1] set args [lrange $args 2 end] } -readonlybackground - -disabledbackground - -selectforeground - -selectbackground - -selectborderwidth - -insertbackground { _foreach $w [list configure $cmd [lindex $args 1]] entry set args [lrange $args 2 end] } -themed { # ignored - only used in widget creation } -textvariable { set name [lindex $args 1] upvar #0 $name var #if {![string match ::* $name]} { set name ::$name } if {[info exists ::ipentry::textvars($w)]} { set trace [trace info variable var] trace remove variable var [lindex $trace 0 0] [lindex $trace 0 1] } set ::ipentry::textvars($w) $name if {![info exists var]} { set var "" } ::ipentry::traceFired $w $name {} write if {[winfo exists $w.4]} { trace add variable var {write unset} [list ::ipentry::traceFired6 $w] } else { trace add variable var {write unset} [list ::ipentry::traceFired $w] } set args [lrange $args 2 end] } default { error "unknown option \"[lindex $args 0]\"" } } } } # destroyWidget -- # # bound to the event # used by both ipentry and ipentry6 # # ARGS: # w name of the ipentry widget # # RETURNS: # nothing # proc ::ipentry::destroyWidget {w} { upvar #0 [namespace current]::widget_$w state if {[info exists ::ipentry::textvars($w)]} { upvar #0 $::ipentry::textvars($w) var set trace [trace info variable var] trace remove variable var [lindex $trace 0 0] [lindex $trace 0 1] } rename $w {} unset state } # traceFired -- # # called by the variable trace on the ipentry textvariable # used by ipentry only # # ARGS: # w name of the ipentry widget # varname name of the variable being traced # key array index of the variable # op operation performed on the variable, read/write/unset # # RETURNS: # nothing # proc ::ipentry::traceFired {w name key op} { upvar #0 $name var if {[info level] > 1} { set caller [lindex [info level -1] 0] if {$caller == "::ipentry::updateTextvar" || $caller == "::ipentry::traceFired"} { return } } if {$op == "write"} { _insert $w [split $var .] set val [string trim [join [$w get] .] .] # allow a dot at the end, but only if we have less than 3 already if {[string index $var end] == "." && [regexp -all {\.+} $var] <= 3} { append val . } if {$val eq $var} return after 0 [list set $name $val] set var $val } elseif {$op == "unset"} { ::ipentry::updateTextvar $w.0 trace add variable var {write unset} [list ipentry::traceFired $w] } } # traceFired6 -- # # called by the variable trace on the ipentry textvariable # used by ipentry6 only # # ARGS: # w name of the ipentry widget # varname name of the variable being traced # key array index of the variable # op operation performed on the variable, read/write/unset # # RETURNS: # nothing # proc ::ipentry::traceFired6 {w name key op} { upvar #0 $name var if {[info level] > 1} { set caller [lindex [info level -1] 0] if {$caller == "::ipentry::updateTextvar" || $caller == "::ipentry::traceFired6"} { return } } if {$op == "write"} { _insert6 $w [split $var :] set val [string trim [join [$w get] :] :] # allow a dot at the end, but only if we have less than 3 already if {[string index $var end] == ":" && [regexp -all {\:+} $var] <= 7} { append val : } if {$val eq $var} return after 0 [list set $name $val] set var $val } elseif {$op == "unset"} { ::ipentry::updateTextvar $w.0 trace add variable var {write unset} [list ipentry::traceFired6 $w] } } # updateTextvar -- # # called by all procs which change the value of the ipentry # used by both ipentry and ipentry6 # # update the textvariable if it exists with the new value # # ARGS: # w name of the ipentry widget # # RETURNS: # nothing # proc ::ipentry::updateTextvar {w} { set p [winfo parent $w] if {![info exists ::ipentry::textvars($p)]} { return } set c [$p.d1 cget -text] set val [string trim [join [$p get] $c] $c] upvar #0 $::ipentry::textvars($p) var if {[info exists var] && $var == $val} { return } set var $val } # _insert -- # # called by the variable trace on the ipentry textvariable and widget insert cmd # used by ipentry only # # ARGS: # w name of an ipentry widget # val a list of 4 values to be inserted into the ipentry # # RETURNS: # nothing # proc ::ipentry::_insert {w val} { foreach x {0 1 2 3} { set n [lindex $val $x] if {$n != ""} { if {![string is integer -strict $n]} { #error "cannot insert non-numeric arguments" return } if {$n > 255} { set n 255 } if {$n <= 0} { set n 0 } if {$x == 0 && $n < 1} { set n 1 } } $w.$x delete 0 end $w.$x insert 0 $n } } # _insert6 -- # # called by the variable trace on the ipentry textvariable and widget insert cmd # used by both ipentry6 only # # ARGS: # w name of an ipentry widget # val a list of 8 values to be inserted into the ipentry # # RETURNS: # nothing # proc ::ipentry::_insert6 {w val} { foreach x {0 1 2 3 4 5 6 7} { set n [lindex $val $x] if {![string is xdigit $n]} { #error "cannot insert non-hex arguments" return } if {$n != "" } { if "$x == 0 && 0x$n < 1" { set n 1 } if "0x$n > 0xffff" { set n ffff } } $w.$x delete 0 end $w.$x insert 0 $n } } # widgetCommand -- # # handle the widgetName command # used by ipentry, with some commands passed through from widgetCommand6 # # ARGS: # w name of the ipentry widget # cmd the subcommand # args arguments to the subcommand # # RETURNS: # the results of the invoked subcommand # proc ::ipentry::widgetCommand {w cmd args} { upvar #0 [namespace current]::widget_$w state switch -exact -- $cmd { get { # return the 4 entry values as a list foreach x {0 1 2 3 4 5 6 7} { if {![winfo exists $w.$x]} { break } set s [$w.$x get] if {[string length $s] > 1} { set s [string trimleft $s 0] if {$s == ""} { set s 0 } } lappend r $s } return $r } insert { _insert $w [join $args] ::ipentry::updateTextvar $w.3 } icursor { if {![string match $w.* [focus]]} { return } set i [lindex $args 0] if {![string is integer -strict $i]} { error "argument must be an integer" } set s [expr {$i / 4}] focus $w.$s $w.$s icursor [expr {$i % 4}] } complete { foreach x {0 1 2 3 4 5 6 7} { if {![winfo exists $w.$x]} { break } if {[$w.$x get] == ""} { return 0 } } return 1 } configure { eval [list ::ipentry::configure $w] $args } cget { return [::ipentry::cget $w [lindex $args 0]] } default { error "bad option \"$cmd\": must be get, insert, complete, cget, or configure" } } } # widgetCommand6 -- # # handle the widgetName command for ipentry6 widgets # most subcommands are passed through to widgetCommand by the default case # # ARGS: # w name of the ipentry widget # cmd the subcommand # args arguments to the subcommand # # RETURNS: # the results of the invoked subcommand # proc ::ipentry::widgetCommand6 {w cmd args} { upvar #0 [namespace current]::widget_$w state switch -exact -- $cmd { insert { _insert6 $w [join $args] ::ipentry::updateTextvar $w.7 } icursor { if {![string match $w.* [focus]]} { return } set i [lindex $args 0] if {![string is integer -strict $i]} { error "argument must be am integer" } set s [expr {$i / 8}] focus $w.$s $w.$s icursor [expr {$i % 8}] } default { return [eval [list ::ipentry::widgetCommand $w $cmd] $args] } } }