[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] page.
----

  #Updated Aug 7, 2002 to fix minor bugs and introduce paste primary

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

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

  proc widget:entry:copy {win type} {
    if {[$win index end] == 0 || [catch {$win index sel.first}]} {
      return
    }
    
    if {[catch {selection get -displayof $win -selection $type -type STRING} data]} {
      return
    }
    clipboard clear -displayof $win
    clipboard append -displayof $win $data
  }
  
  proc widget:entry:paste {win type} {
    if {[catch {selection get -displayof $win -selection $type -type STRING} data]} {
      return
    }
    $win insert insert $data
  }
  
  proc widget:entry:cut {win type} {
    if {[catch {$win index sel.first}]} {
      return
    }
  
    if {[catch {selection get -displayof $win -selection $type -type STRING} data]} {
      return
    }
    $win delete sel.first sel.last
    clipboard clear -displayof $win
    clipboard append -displayof $win $data
  }
  
  proc widget:entry:append {win type} {
    if {[$win index end] == 0 || [catch {$win index sel.first}]} {
      return
    }
    
    if {[catch {selection get -displayof $win -selection $type -type STRING} data]} {
      return
    }
    clipboard append -displayof $win $data
  }
  
  proc widget:entry:clear {win} {
    $win delete 0 end
  }
  
  proc widget:entry:event:ButtonPress-3 {win X Y} {
    destroy $win._popup
    set m [menu $win._popup -tearoff 0]
  
    #valid types are PRIMARY and CLIPBOARD
  
    $m add command -label Copy -command "widget:entry:copy $win PRIMARY"
    $m add command -label "Paste Primary" -command "widget:entry:paste $win PRIMARY"
    $m add command -label "Paste Clipboard" -command "widget:entry:paste $win CLIPBOARD"
    $m add command -label Cut -command "widget:entry:cut $win PRIMARY"
    $m add command -label Append -command "widget:entry:append $win PRIMARY"
    $m add command -label Clear -command "widget:entry:clear $win"
  
    tk_popup $m $X $Y
  }
  
  proc widget:entry: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:entry: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
----

[Category GUI]