Open Mash Cross Reference
mash/tcl/common/entry.tcl

   # entry.tcl --
   #
   #       FIXME: This file needs a description here.
   #
   # Copyright (c) 1993-2002 The Regents of the University of California.
   # All rights reserved.
   #
   # Redistribution and use in source and binary forms, with or without
   # modification, are permitted provided that the following conditions are met:
  #
  # A. Redistributions of source code must retain the above copyright notice,
  #    this list of conditions and the following disclaimer.
  # B. Redistributions in binary form must reproduce the above copyright notice,
  #    this list of conditions and the following disclaimer in the documentation
  #    and/or other materials provided with the distribution.
  # C. Neither the names of the copyright holders nor the names of its
  #    contributors may be used to endorse or promote products derived from this
  #    software without specific prior written permission.
  #
  # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS''
  # AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
  # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  # ARE DISCLAIMED.  IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR
  # ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
  # SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
  # CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
  # OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
  # OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  #
  # @(#) $Header: /usr/mash/src/repository/mash/mash-1/tcl/common/entry.tcl,v 1.17 2002/02/14 18:22:08 lim Exp $
  
  
  #
  # For any entry created, the global (array) entryTab($w:object)
  # contains the name of the Otcl object to invoke when the entry is
  # updated (where $w is the wind path of the entry widget).
  # The "update" method takes one arg: the new value.
  # It should return 0 if the edit should be accepted,
  # and non-zero otherwise.  entryTab($w:value) should be
  # set to the initial value when the widget is created
  # (hidden in Entry base class).
  #
  
  bind Entry <Enter> {
          catch {
                  global entryTab
                  if $entryTab(%W:focus) {
                          focus %W
                  }
          }
  }
  bind Entry <Return> {
      set validateMode [%W cget -validate]
      %W validate
      %W configure -validate $validateMode
  }
  bind Entry <Escape> {
          focus .
          %W select clear
          %W delete 0 end
          catch {
                  global entryTab
                  set entryTab(%W:focus) 0
                  %W insert 0 $entryTab(%W:value)
          }
  }
  bind Entry <Control-g> [bind Entry <Escape>]
  
  bind Entry <Control-u> {
      tkEntrySetCursor %W 0
      %W delete insert end
  }
  
  proc mk.entry { w action text } {
          puts stderr "Use the new Entry class"
          exit 1
  }
  
  Class Entry
  
  # calls {$obj update key} if obj is not null,
  # otherwise calls {$self update key}
  #
  Entry instproc init { w value {obj {}} } {
          $self instvar win_
          set win_ $w
          entry $w -relief raised -borderwidth 1 -exportselection 1 \
                  -font [$self get_option entryFont] \
                  -validate focusout -validatecommand "$self validate %W %P"
          global entryTab
          if {$obj == {}} {
                  set entryTab($w:object) $self
          } else {
                  set entryTab($w:object) $obj
          }
          set entryTab($w:value) $value
          $w insert 0 $value
  }
 
 Entry instproc entry-value { } {
         global entryTab
         $self instvar win_
         $win_ validate
         return $entryTab($win_:value)
 }
 
 Entry instproc set-value {v} {
         global entryTab
         $self instvar win_
         $win_ delete 0 end
         $win_ insert 0 $v
         set entryTab($win_:value) $v
 }
 
 Entry instproc clear { } {
         global entryTab
         $self instvar win_
         set entryTab($win_:value) 0
         $win_ insert 0 ""
 }
 
 Entry instproc validate {entryName newValue} {
     global entryTab
     $self instvar win_
 
     set validateResult 1
     set oldValue $entryTab($entryName:value)
 
     if {[catch {set reject [$entryTab($entryName:object) update $newValue]}]} {
 
         # The update method doesn't exist or it had a runtime error.
 
         set reject 0
     }
 
     if {$reject} {
         $win_ delete 0 end
         $win_ insert 0 $oldValue
         bell
         set validateResult 0
     } else {
         set entryTab($entryName:value) $newValue
         set validateResult 1
     }
 
     return $validateResult
 }