Version 1 of widget:entry

Updated 2002-05-28 08:13:03

GPS is still editing this!

GPS May 27, 2002: I wanted an extended entry box that provides by default copy, paste, cut, and append options via a popup menu. I also wanted the ability to restrict the data entered to a RE pattern. The solution below provides a modified entry widget that does all of the above. It is standalone, but does use one of the binding procs from the Inheriting Widget Binding Classes.


  #! /bin/wish8.3

  proc bind:copyClass {class newClass} {
    set bindingList [bind $class]

    foreach binding $bindingList {
      bind $newClass $binding [bind $class $binding]
    }
  }

  proc widget:entry:copy {win} {
    if {[$win index end] == 0 || [catch {$win index sel.first}]} {
      return
    }

    set selectedData [selection get -displayof $win]
    clipboard clear -displayof $win
    clipboard append -displayof $win $selectedData
  }

  proc widget:entry:paste {win} {
    $win insert insert [selection get -displayof $win -selection CLIPBOARD]
  }

  proc widget:entry:cut {win} {
    if {[catch {$win index sel.first}]} {
      return
    }

    set selectedData [selection get -displayof $win]
    $win delete sel.first sel.last
    clipboard clear -displayof $win
    clipboard append -displayof $win $selectedData
  }

  proc widget:entry:append {win} {
    if {[$win index end] == 0 || [catch {$win index sel.first}]} {
      return
    }

    set selectedData [selection get -displayof $win]
    clipboard append -displayof $win $selectedData
  }

  proc widget:entry:event:ButtonPress-3 {win X Y} {
    destroy $win._popup
    set m [menu $win._popup -tearoff 0]

    $m add command -label Copy -command "widget:entry:copy $win"
    $m add command -label Paste -command "widget:entry:paste $win"
    $m add command -label Cut -command "widget:entry:cut $win"
    $m add command -label Append -command "widget:entry:append $win"

    tk_popup $m $X $Y
  }

  proc widget:instanceCmd {win args} {
    upvar #0 widget:entry$win inputRegexp
    set cmd [lindex $args 0]
    set useInputRegexp 0
    set isInsert 0

    if {[string length $inputRegexp] > 0} {
      set useInputRegexp 1
    }

    if {[string equal $cmd "insert"]} {
      set isInsert 1
    }

    if {$isInsert && $useInputRegexp} {
      set data [lrange $args 2 end]

      set valid 1
      foreach char [split $data ""] {
        if {[regexp $inputRegexp $char] <= 0} {
          set valid 0
          break
        }
      }
      if {$valid} {
        return [uplevel 2 widget:entry:origCmd$win $args]
      }
    } else {
      return [uplevel 2 widget:entry:origCmd$win $args]
    }
  }

  proc widget:entry {win args} {
    upvar #0 widget:entry$win inputRegexp
    set inputRegexp ""

    if {[set pos [lsearch $args "-inputregexp"]] > -1} {
      set posRe [expr {$pos + 1}]
      set inputRegexp [lindex $args $posRe]
      set args [lreplace $args $pos $posRe]
    }

    eval entry [concat $win $args] 

    bind:copyClass Entry Widget:Entry

    bind Widget:Entry <ButtonPress-3> {widget:entry:event:ButtonPress-3 %W %X %Y}

    #use our new binding class
    bindtags $win "$win Widget:Entry all"

    rename $win widget:entry:origCmd$win
    proc $win {args} "eval widget:instanceCmd $win \$args"

    return $win
  }

  #BEGIN test code
  proc checkIP {win clientData} {
    set RE {[0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3}}

    set data [$win get]

    set result 1
    if {[regexp $RE $data] > 0} {
      foreach num [split $data .] {
        if {$num < 0 || $num > 255} {
          set result 0
          break
        }
      }
    } else {
      set result 0
    }

    eval [concat $clientData $result]
  }

  proc main {} {
    pack [widget:entry .e -inputregexp {[0-9\.]} -width 20]
    .e insert end abc ;#should fail
    pack [frame .info] -side left -fill x
    pack [label .info.valid -text "Valid: "] -side left
    pack [label .info.bool -text 0] -side left
    #I could use a textvariable but this works
    pack [button .checkIP -text "Check IP" -command "checkIP .e {.info.bool config -text}"]
    pack [button .exit -text Exit -command exit]
  }
  main