source xowidget.tcl

package require Tcl 8.4
package require Tk 8.4
package require XOTcl 1.2
package require xowidget

namespace import ::xotcl::*
namespace import ::xowidget::*

WidgetClass SearchableListbox \
    -tkwidget labelframe \
    -parameter {
       {pattern ""}
       {foo foo}
    }

SearchableListbox instproc init {args} {
   next
   my instvar widgetpath
   my requireNamespace
   # construct the user interface elements
   my BuildUi
   # add the options available to the tk widget facade
   my tkoption add widgetproc [self] \
       -only {
	  {text title}
	  relief
	  borderwidth
	  background
       }
   my tkoption add parameter [self] \
       -translate {
	  pattern searchpattern
       }
   # propogate background option to many widgets
   foreach comp {l b xs ys sframe xframe} {
      my tkoption add tkwidget $widgetpath.$comp \
	  -only { background }
   }
   my tkoption add tkwidget $widgetpath.b \
       -prefix "button" \
       -except {
	  background
	  command
       }
   my tkoption add tkwidget $widgetpath.l \
       -prefix "label" \
       -except {
	  background
       }
   my tkoption add tkwidget $widgetpath.e \
       -prefix "list" \
       -only {
	  background
	  foreground
       }
   my tkoption add tkwidget $widgetpath.lbx \
       -translate {
	  background listbackground
	  foreground listforeground
       } \
       -except {
	  yscrollcommand
	  xscrollcommand
       }

   my tkoption alias foo superfoo

   # add the commands available to the tk widget facade. We will make our
   # widget compatible with the standard listbox and we will add one new
   # method, "search"
   my tkcommand add * "$widgetpath.lbx"
   my tkcommand add search
   my tkcommand add pattern

   # initialize some data members we will need while searching
   my set lastPattern ""
   my set lastIndex 0
}

SearchableListbox instproc BuildUi {} {
   my instvar widgetpath
   frame $widgetpath.xframe -bd 0
   frame $widgetpath.sframe -bd 0
   listbox $widgetpath.lbx \
       -yscrollcommand [list $widgetpath.ys set] \
       -xscrollcommand [list $widgetpath.xs set]
   scrollbar $widgetpath.ys \
       -command [list $widgetpath.lbx yview]
   scrollbar $widgetpath.xs \
       -command [list $widgetpath.lbx xview] \
       -orient horizontal
   label $widgetpath.l
   entry $widgetpath.e \
       -textvariable "[self]::pattern"
   button $widgetpath.b \
       -command [list [self] search]
   grid $widgetpath.lbx $widgetpath.ys  -stick news -in $widgetpath.xframe
   grid $widgetpath.xs  x               -stick ew   -in $widgetpath.xframe
   grid columnconfigure $widgetpath.xframe 0 -weight 1
   grid rowconfigure $widgetpath.xframe 0 -weight 1

   grid $widgetpath.l   $widgetpath.e - $widgetpath.b \
       -stick ew -in $widgetpath.sframe
   grid configure $widgetpath.e -padx 4
   grid columnconfigure $widgetpath.sframe 1 -weight 1
   grid rowconfigure $widgetpath.sframe 0 -weight 1

   grid $widgetpath.xframe -stick news -padx 4 -pady 4
   grid $widgetpath.sframe -stick news -padx 4 -pady 4
   grid columnconfigure $widgetpath 0 -weight 1
   grid rowconfigure $widgetpath 0 -weight 1

   bind $widgetpath.e <Any-KeyRelease> [list [self] search 1]
   bind $widgetpath.e <KeyRelease-Return> "[list [self] search];break"
}


SearchableListbox instproc search { {retainSearchIndex 0}} {
   my instvar widgetpath lastIndex lastPattern pattern
   # case insensitive list of items in the listbox
   set list [string tolower [$widgetpath.lbx get 0 end]]
   if {($list eq "") || ($pattern eq "")} {
      return
   }
   if {$lastIndex >= [$widgetpath.lbx index end]} {
      set lastIndex 0
      set lastPattern ""
      bell
      return
   } elseif {$retainSearchIndex == 0 && $pattern ne $lastPattern} {
      set lastIndex 0
   }

   # case insensivite, glob pattern version of the search string
   set sPattern "*[string tolower $pattern]*"
   set index [lsearch -glob -start $lastIndex $list $sPattern]
   if {$index == -1} {
      # did not find the pattern
      bell
      set lastIndex 0
      set lastPattern ""
      return
   }
   # adjust the selection and viewport
   $widgetpath.lbx select clear 0 end
   $widgetpath.lbx select set $index
   $widgetpath.lbx see $index
   # remember the last pattern and where we found it
   set lastPattern $pattern
   if {$retainSearchIndex == 0} {
      set lastIndex [incr index]
   } else {
      set lastIndex $index
   }
}



SearchableListbox .s
SearchableListbox .s2 \
    -title "Another List" \
    -buttontext "Find" \
    -labeltext "Search Pattern:" \
    -background blue \
    -relief flat \
    -listbackground "cyan" \
    -listforeground "dark blue" \
    -selectbackground yellow \
    -selectforeground black

pack .s  -fill both -expand 1 -padx 4 -pady 4
pack .s2  -fill both -expand 1 -padx 4 -pady 4

.s configure \
    -title "Foo Searchable List" \
    -buttontext "Find It" \
    -labeltext "Search"
puts "configuration: [.s configure]"

.s insert end \
    foo \
    bar \
    "ack ack" \
    "All your base are belong to us!" \
    "Smackaroo!" \
    "Superpickles to the rescue!" \
    "Emacs for teh win!" \
    foo \
    bar \
    "ack ack" \
    "All your base are belong to us!" \
    "Smackaroo!" \
    "Superpickles to the rescue!" \
    "Emacs for teh win!"

eval .s2 insert end [.s get 0 end]

.s2 pattern "ack"
.s configure -searchpattern "foo"

puts "pattern: [.s configure -searchpattern]"
puts "foo: [.s configure -foo] == [.s configure -superfoo]"