home *** CD-ROM | disk | FTP | other *** search
/ PC World 2005 June / PCWorld_2005-06_cd.bin / software / vyzkuste / firewally / firewally.exe / framework-2.3.exe / entryfield.itk < prev    next >
Encoding:
Text File  |  2003-09-01  |  20.9 KB  |  604 lines
  1. #
  2. # Entryfield
  3. # ----------------------------------------------------------------------
  4. # Implements an enhanced text entry widget.
  5. #
  6. # ----------------------------------------------------------------------
  7. #   AUTHOR:  Sue Yockey               E-mail: yockey@acm.org
  8. #            Mark L. Ulferts          E-mail: mulferts@austin.dsccc.com
  9. #
  10. #   @(#) $Id: entryfield.itk,v 1.6 2001/09/17 19:24:46 smithc Exp $
  11. # ----------------------------------------------------------------------
  12. #            Copyright (c) 1995 DSC Technologies Corporation
  13. # ======================================================================
  14. # Permission to use, copy, modify, distribute and license this software 
  15. # and its documentation for any purpose, and without fee or written 
  16. # agreement with DSC, is hereby granted, provided that the above copyright 
  17. # notice appears in all copies and that both the copyright notice and 
  18. # warranty disclaimer below appear in supporting documentation, and that 
  19. # the names of DSC Technologies Corporation or DSC Communications 
  20. # Corporation not be used in advertising or publicity pertaining to the 
  21. # software without specific, written prior permission.
  22. # 
  23. # DSC DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING 
  24. # ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, AND NON-
  25. # INFRINGEMENT. THIS SOFTWARE IS PROVIDED ON AN "AS IS" BASIS, AND THE
  26. # AUTHORS AND DISTRIBUTORS HAVE NO OBLIGATION TO PROVIDE MAINTENANCE, 
  27. # SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. IN NO EVENT SHALL 
  28. # DSC BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR 
  29. # ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, 
  30. # WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTUOUS ACTION,
  31. # ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS 
  32. # SOFTWARE.
  33. # ======================================================================
  34.  
  35. #
  36. # Usual options.
  37. #
  38. itk::usual Entryfield {
  39.     keep -background -borderwidth -cursor -foreground -highlightcolor \
  40.      -highlightthickness -insertbackground -insertborderwidth \
  41.      -insertofftime -insertontime -insertwidth -labelfont \
  42.      -selectbackground -selectborderwidth -selectforeground \
  43.      -textbackground -textfont
  44. }
  45.  
  46. # ------------------------------------------------------------------
  47. #                            ENTRYFIELD
  48. # ------------------------------------------------------------------
  49. itcl::class iwidgets::Entryfield {
  50.     inherit iwidgets::Labeledwidget 
  51.     
  52.     constructor {args} {}
  53.  
  54.     itk_option define -childsitepos childSitePos Position e
  55.     itk_option define -command command Command {}
  56.     itk_option define -fixed fixed Fixed 0
  57.     itk_option define -focuscommand focusCommand Command {}
  58.     itk_option define -invalid invalid Command {bell}
  59.     itk_option define -pasting pasting Behavior 1
  60.     itk_option define -validate validate Command {}
  61.     
  62.     public {
  63.     method childsite {}
  64.     method get {}
  65.     method delete {args}
  66.     method icursor {args}
  67.     method index {args}
  68.     method insert {args}
  69.     method scan {args}
  70.     method selection {args}
  71.     method xview {args}
  72.     method clear {}
  73.     }
  74.  
  75.     proc numeric {char} {}
  76.     proc integer {string} {}
  77.     proc alphabetic {char} {}
  78.     proc alphanumeric {char} {}
  79.     proc hexidecimal {string} {}
  80.     proc real {string} {}
  81.  
  82.     protected {
  83.     method _focusCommand {}
  84.     method _keyPress {char sym state}
  85.     }
  86.  
  87.     private method _peek {char}
  88.     private method _checkLength {}
  89. }
  90.  
  91. #
  92. # Provide a lowercased access method for the Entryfield class.
  93. # 
  94. proc ::iwidgets::entryfield {pathName args} {
  95.     uplevel ::iwidgets::Entryfield $pathName $args
  96. }
  97.  
  98. # ------------------------------------------------------------------
  99. #                        CONSTRUCTOR
  100. # ------------------------------------------------------------------
  101. itcl::body iwidgets::Entryfield::constructor {args} {
  102.     component hull configure -borderwidth 0
  103.     
  104.     itk_component add entry {
  105.     entry $itk_interior.entry
  106.     } {
  107.     keep -borderwidth -cursor -exportselection \
  108.         -foreground -highlightcolor \
  109.         -highlightthickness -insertbackground -insertborderwidth \
  110.         -insertofftime -insertontime -insertwidth -justify \
  111.         -relief -selectbackground -selectborderwidth \
  112.         -selectforeground -show -state -textvariable -width
  113.     
  114.     rename -font -textfont textFont Font
  115.     rename -highlightbackground -background background Background
  116.     rename -background -textbackground textBackground Background
  117.     }
  118.     
  119.     #
  120.     # Create the child site widget.
  121.     #
  122.     itk_component add -protected efchildsite {
  123.     frame $itk_interior.efchildsite
  124.     } 
  125.     set itk_interior $itk_component(efchildsite)
  126.     
  127.     #
  128.     # Entryfield instance bindings.
  129.     #
  130.     bind $itk_component(entry) <KeyPress> [itcl::code $this _keyPress %A %K %s]
  131.     bind $itk_component(entry) <FocusIn> [itcl::code $this _focusCommand]
  132.  
  133.     #
  134.     # Initialize the widget based on the command line options.
  135.     #
  136.     eval itk_initialize $args
  137. }
  138.  
  139. # ------------------------------------------------------------------
  140. #                             OPTIONS
  141. # ------------------------------------------------------------------
  142.  
  143. # ------------------------------------------------------------------
  144. # OPTION: -command
  145. #
  146. # Command associated upon detection of Return key press event
  147. # ------------------------------------------------------------------
  148. itcl::configbody iwidgets::Entryfield::command {}
  149.  
  150. # ------------------------------------------------------------------
  151. # OPTION: -focuscommand
  152. #
  153. # Command associated upon detection of focus.
  154. # ------------------------------------------------------------------
  155. itcl::configbody iwidgets::Entryfield::focuscommand {}
  156.  
  157. # ------------------------------------------------------------------
  158. # OPTION: -validate
  159. #
  160. # Specify a command to executed for the validation of Entryfields.
  161. # ------------------------------------------------------------------
  162. itcl::configbody iwidgets::Entryfield::validate {
  163.     switch $itk_option(-validate) {
  164.     {} {
  165.         set itk_option(-validate) {}
  166.     }
  167.     numeric {
  168.         set itk_option(-validate) "::iwidgets::Entryfield::numeric %c"
  169.     }
  170.     integer {
  171.         set itk_option(-validate) "::iwidgets::Entryfield::integer %P"
  172.     }
  173.     hexidecimal {
  174.         set itk_option(-validate) "::iwidgets::Entryfield::hexidecimal %P"
  175.     }
  176.     real {
  177.         set itk_option(-validate) "::iwidgets::Entryfield::real %P"
  178.     }
  179.     alphabetic {
  180.         set itk_option(-validate) "::iwidgets::Entryfield::alphabetic %c"
  181.     }
  182.     alphanumeric {
  183.         set itk_option(-validate) "::iwidgets::Entryfield::alphanumeric %c"
  184.     }
  185.     }
  186. }
  187.  
  188. # ------------------------------------------------------------------
  189. # OPTION: -invalid
  190. #
  191. # Specify a command to executed should the current Entryfield contents
  192. # be proven invalid.
  193. # ------------------------------------------------------------------
  194. itcl::configbody iwidgets::Entryfield::invalid {}
  195.  
  196. # ------------------------------------------------------------------
  197. # OPTION: -pasting
  198. #
  199. # Allows the developer to enable and disable pasting into the entry
  200. # component of the entryfield.  This is done to avoid potential stack
  201. # dumps when using the -validate configuration option.  Plus, it's just
  202. # a good idea to have complete control over what you allow the user
  203. # to enter into the entryfield.
  204. # ------------------------------------------------------------------
  205. itcl::configbody iwidgets::Entryfield::pasting {
  206.   set oldtags [bindtags $itk_component(entry)]
  207.   if {[lindex $oldtags 0] != "pastetag"} {
  208.     bindtags $itk_component(entry) [linsert $oldtags 0 pastetag] 
  209.   }
  210.  
  211.   if ($itk_option(-pasting)) {
  212.     bind pastetag <ButtonRelease-2> [itcl::code $this _checkLength]
  213.     bind pastetag <Control-v> [itcl::code $this _checkLength]
  214.     bind pastetag <Insert> [itcl::code $this _checkLength]
  215.     bind pastetag <KeyPress> {}
  216.   } else {
  217.     bind pastetag <ButtonRelease-2> {break}
  218.     bind pastetag <Control-v> {break}
  219.     bind pastetag <Insert> {break}
  220.     bind pastetag <KeyPress> {
  221.       # Disable function keys > F9.
  222.       if {[regexp {^F[1,2][0-9]+$} "%K"]} {
  223.     break
  224.       }
  225.     }
  226.   }
  227. }
  228.  
  229. # ------------------------------------------------------------------
  230. # OPTION: -fixed
  231. #
  232. # Restrict entry to 0 (unlimited) chars.  The value is the maximum 
  233. # number of chars the user may type into the field, regardles of 
  234. # field width, i.e. the field width may be 20, but the user will 
  235. # only be able to type -fixed number of characters into it (or 
  236. # unlimited if -fixed = 0).
  237. # ------------------------------------------------------------------
  238. itcl::configbody iwidgets::Entryfield::fixed {
  239.     if {[regexp {[^0-9]} $itk_option(-fixed)] || \
  240.         ($itk_option(-fixed) < 0)} {
  241.     error "bad fixed option \"$itk_option(-fixed)\",\
  242.         should be positive integer"
  243.     }
  244. }
  245.  
  246. # ------------------------------------------------------------------
  247. # OPTION: -childsitepos
  248. #
  249. # Specifies the position of the child site in the widget.
  250. # ------------------------------------------------------------------
  251. itcl::configbody iwidgets::Entryfield::childsitepos {
  252.     set parent [winfo parent $itk_component(entry)]
  253.  
  254.     switch $itk_option(-childsitepos) {
  255.     n {
  256.         grid $itk_component(efchildsite) -row 0 -column 0 -sticky ew
  257.         grid $itk_component(entry) -row 1 -column 0 -sticky nsew
  258.  
  259.         grid rowconfigure $parent 0 -weight 0
  260.         grid rowconfigure $parent 1 -weight 1
  261.         grid columnconfigure $parent 0 -weight 1
  262.         grid columnconfigure $parent 1 -weight 0
  263.     }
  264.     
  265.     e {
  266.         grid $itk_component(efchildsite) -row 0 -column 1 -sticky ns
  267.         grid $itk_component(entry) -row 0 -column 0 -sticky nsew
  268.  
  269.         grid rowconfigure $parent 0 -weight 1
  270.         grid rowconfigure $parent 1 -weight 0
  271.         grid columnconfigure $parent 0 -weight 1
  272.         grid columnconfigure $parent 1 -weight 0
  273.     }
  274.     
  275.     s {
  276.         grid $itk_component(efchildsite) -row 1 -column 0 -sticky ew
  277.         grid $itk_component(entry) -row 0 -column 0 -sticky nsew
  278.  
  279.         grid rowconfigure $parent 0 -weight 1
  280.         grid rowconfigure $parent 1 -weight 0
  281.         grid columnconfigure $parent 0 -weight 1
  282.         grid columnconfigure $parent 1 -weight 0
  283.     }
  284.     
  285.     w {
  286.         grid $itk_component(efchildsite) -row 0 -column 0 -sticky ns
  287.         grid $itk_component(entry) -row 0 -column 1 -sticky nsew
  288.  
  289.         grid rowconfigure $parent 0 -weight 1
  290.         grid rowconfigure $parent 1 -weight 0
  291.         grid columnconfigure $parent 0 -weight 0
  292.         grid columnconfigure $parent 1 -weight 1
  293.     }
  294.     
  295.     default {
  296.         error "bad childsite option\
  297.             \"$itk_option(-childsitepos)\":\
  298.             should be n, e, s, or w"
  299.     }
  300.     }
  301. }
  302.  
  303. # ------------------------------------------------------------------
  304. #                            METHODS
  305. # ------------------------------------------------------------------
  306.  
  307. # ------------------------------------------------------------------
  308. # METHOD: childsite
  309. #
  310. # Returns the path name of the child site widget.
  311. # ------------------------------------------------------------------
  312. itcl::body iwidgets::Entryfield::childsite {} {
  313.     return $itk_component(efchildsite)
  314. }
  315.  
  316. # ------------------------------------------------------------------
  317. # METHOD: get 
  318. #
  319. # Thin wrap of the standard entry widget get method.
  320. # ------------------------------------------------------------------
  321. itcl::body iwidgets::Entryfield::get {} {
  322.     return [$itk_component(entry) get]
  323. }
  324.  
  325. # ------------------------------------------------------------------
  326. # METHOD: delete
  327. #
  328. # Thin wrap of the standard entry widget delete method.
  329. # ------------------------------------------------------------------
  330. itcl::body iwidgets::Entryfield::delete {args} {
  331.     return [eval $itk_component(entry) delete $args]
  332. }
  333.  
  334. # ------------------------------------------------------------------
  335. # METHOD: icursor 
  336. #
  337. # Thin wrap of the standard entry widget icursor method.
  338. # ------------------------------------------------------------------
  339. itcl::body iwidgets::Entryfield::icursor {args} {
  340.     return [eval $itk_component(entry) icursor $args]
  341. }
  342.  
  343. # ------------------------------------------------------------------
  344. # METHOD: index 
  345. #
  346. # Thin wrap of the standard entry widget index method.
  347. # ------------------------------------------------------------------
  348. itcl::body iwidgets::Entryfield::index {args} {
  349.     return [eval $itk_component(entry) index $args]
  350. }
  351.  
  352. # ------------------------------------------------------------------
  353. # METHOD: insert 
  354. #
  355. # Thin wrap of the standard entry widget index method.
  356. # ------------------------------------------------------------------
  357. itcl::body iwidgets::Entryfield::insert {args} {
  358.     return [eval $itk_component(entry) insert $args]
  359. }
  360.  
  361. # ------------------------------------------------------------------
  362. # METHOD: scan 
  363. #
  364. # Thin wrap of the standard entry widget scan method.
  365. # ------------------------------------------------------------------
  366. itcl::body iwidgets::Entryfield::scan {args} {
  367.     return [eval $itk_component(entry) scan $args]
  368. }
  369.  
  370. # ------------------------------------------------------------------
  371. # METHOD: selection
  372. #
  373. # Thin wrap of the standard entry widget selection method.
  374. # ------------------------------------------------------------------
  375. itcl::body iwidgets::Entryfield::selection {args} {
  376.     return [eval $itk_component(entry) selection $args]
  377. }
  378.  
  379. # ------------------------------------------------------------------
  380. # METHOD: xview 
  381. #
  382. # Thin wrap of the standard entry widget xview method.
  383. # ------------------------------------------------------------------
  384. itcl::body iwidgets::Entryfield::xview {args} {
  385.     return [eval $itk_component(entry) xview $args]
  386. }
  387.  
  388. # ------------------------------------------------------------------
  389. # METHOD: clear 
  390. #
  391. # Delete the current entry contents.
  392. # ------------------------------------------------------------------
  393. itcl::body iwidgets::Entryfield::clear {} {
  394.     $itk_component(entry) delete 0 end
  395.     icursor 0
  396. }
  397.  
  398. # ------------------------------------------------------------------
  399. # PROCEDURE: numeric char
  400. #
  401. # The numeric procedure validates character input for a given 
  402. # Entryfield to be numeric and returns the result.
  403. # ------------------------------------------------------------------
  404. itcl::body iwidgets::Entryfield::numeric {char} {
  405.     return [regexp {[0-9]} $char]
  406. }
  407.  
  408. # ------------------------------------------------------------------
  409. # PROCEDURE: integer string
  410. #
  411. # The integer procedure validates character input for a given 
  412. # Entryfield to be integer and returns the result.
  413. # ------------------------------------------------------------------
  414. itcl::body iwidgets::Entryfield::integer {string} {
  415.     return [regexp {^[-+]?[0-9]*$} $string]
  416. }
  417.  
  418. # ------------------------------------------------------------------
  419. # PROCEDURE: alphabetic char
  420. #
  421. # The alphabetic procedure validates character input for a given 
  422. # Entryfield to be alphabetic and returns the result.
  423. # ------------------------------------------------------------------
  424. itcl::body iwidgets::Entryfield::alphabetic {char} {
  425.     return [regexp -nocase {[a-z]} $char]
  426. }
  427.  
  428. # ------------------------------------------------------------------
  429. # PROCEDURE: alphanumeric char
  430. #
  431. # The alphanumeric procedure validates character input for a given 
  432. # Entryfield to be alphanumeric and returns the result.
  433. # ------------------------------------------------------------------
  434. itcl::body iwidgets::Entryfield::alphanumeric {char} {
  435.     return [regexp -nocase {[0-9a-z]} $char]
  436. }
  437.  
  438. # ------------------------------------------------------------------
  439. # PROCEDURE: hexadecimal string
  440. #
  441. # The hexidecimal procedure validates character input for a given 
  442. # Entryfield to be hexidecimal and returns the result.
  443. # ------------------------------------------------------------------
  444. itcl::body iwidgets::Entryfield::hexidecimal {string} {
  445.     return [regexp {^(0x)?[0-9a-fA-F]*$} $string]
  446. }
  447.  
  448. # ------------------------------------------------------------------
  449. # PROCEDURE: real string
  450. #
  451. # The real procedure validates character input for a given Entryfield
  452. # to be real and returns the result.
  453. # ------------------------------------------------------------------
  454. itcl::body iwidgets::Entryfield::real {string} {
  455.     return [regexp {^[-+]?[0-9]*\.?[0-9]*([0-9]\.?[eE][-+]?[0-9]*)?$} $string]
  456. }
  457.  
  458. # ------------------------------------------------------------------
  459. # PRIVATE METHOD: _peek char
  460. #
  461. # The peek procedure returns the value of the Entryfield with the
  462. # char inserted at the insert position.
  463. # ------------------------------------------------------------------
  464. itcl::body iwidgets::Entryfield::_peek {char} {
  465.     set str [get]
  466.  
  467.     set insertPos [index insert] 
  468.     set firstPart [string range $str 0 [expr {$insertPos - 1}]]
  469.     set lastPart [string range $str $insertPos end]
  470.  
  471.     regsub -all {\\} "$char" {\\\\} char
  472.     append rtnVal $firstPart $char $lastPart
  473.     return $rtnVal
  474. }
  475.  
  476. # ------------------------------------------------------------------
  477. # PROTECTED METHOD: _focusCommand
  478. #
  479. # Method bound to focus event which evaluates the current command
  480. # specified in the focuscommand option
  481. # ------------------------------------------------------------------
  482. itcl::body iwidgets::Entryfield::_focusCommand {} {
  483.     uplevel #0 $itk_option(-focuscommand)
  484. }
  485.  
  486. # ------------------------------------------------------------------
  487. # PROTECTED METHOD: _keyPress 
  488. #
  489. # Monitor the key press event checking for return keys, fixed width
  490. # specification, and optional validation procedures.
  491. # ------------------------------------------------------------------
  492. itcl::body iwidgets::Entryfield::_keyPress {char sym state} {
  493.     #
  494.     # A Return key invokes the optionally specified command option.
  495.     #
  496.     if {$sym == "Return"} {
  497.     uplevel #0 $itk_option(-command)
  498.     return -code break 1
  499.     } 
  500.     
  501.     #
  502.     # Tabs, BackSpace, and Delete are passed on for other bindings.
  503.     #
  504.     if {($sym == "Tab") || ($sym == "BackSpace") || ($sym == "Delete")} {
  505.     return -code continue 1
  506.     }
  507.  
  508.     # 
  509.     # Character is not printable or the state is greater than one which
  510.     # means a modifier was used such as a control, meta key, or control
  511.     # or meta key with numlock down.
  512.     #
  513.     #-----------------------------------------------------------
  514.     # BUG FIX: csmith (Chad Smith: csmith@adc.com), 3/15/99
  515.     #-----------------------------------------------------------
  516.     # The following conditional used to hardcode specific state values, such
  517.     # as "4" and "8".  These values are used to detect <Ctrl>, <Shift>, etc.
  518.     # key combinations.  On the windows platform, the <Alt> key is state
  519.     # 16, and on the unix platform, the <Alt> key is state 8.  All <Ctrl>
  520.     # and <Alt> combinations should be masked out, regardless of the
  521.     # <NumLock> or <CapsLock> status, and regardless of platform.
  522.     #-----------------------------------------------------------
  523.     set CTRL 4
  524.     global tcl_platform
  525.     if {$tcl_platform(platform) == "unix"} {
  526.       set ALT 8
  527.     } elseif {$tcl_platform(platform) == "windows"} {
  528.       set ALT 16
  529.     } else {
  530.       # This is something other than UNIX or WINDOWS.  Default to the
  531.       # old behavior (UNIX).
  532.       set ALT 8
  533.     }
  534.     # Thanks to Rolf Schroedter for the following elegant conditional.  This
  535.     # masks out all <Ctrl> and <Alt> key combinations.
  536.     if {($char == "") || ($state & ($CTRL | $ALT))} {
  537.       return -code continue 1
  538.     }
  539.  
  540.     #
  541.     # If the fixed length option is not zero, then verify that the
  542.     # current length plus one will not exceed the limit.  If so then
  543.     # invoke the invalid command procedure.
  544.     #
  545.     if {$itk_option(-fixed) != 0} {
  546.     if {[string length [get]] >= $itk_option(-fixed)} {
  547.         uplevel #0 $itk_option(-invalid)
  548.         return -code break 0
  549.     }
  550.     } 
  551.     
  552.     #
  553.     # The validate option may contain a keyword (numeric, alphabetic),
  554.     # the name of a procedure, or nothing.  The numeric and alphabetic
  555.     # keywords engage typical base level checks.  If a command procedure
  556.     # is specified, then invoke it with the object and character passed
  557.     # as arguments.  If the validate procedure returns false, then the 
  558.     # invalid procedure is called.
  559.     #
  560.     if {$itk_option(-validate) != {}} {
  561.     set cmd $itk_option(-validate)
  562.  
  563.     regsub -all "%W" "$cmd" $itk_component(hull) cmd
  564.     regsub -all "%P" "$cmd" [list [_peek $char]] cmd
  565.     regsub -all "%S" "$cmd" [list [get]] cmd
  566.     regsub -all "%c" "$cmd" [list $char] cmd
  567.         regsub -all {\\} "$cmd" {\\\\} cmd
  568.  
  569.     set valid [uplevel #0 $cmd]
  570.     
  571.     if {($valid == "") || ([regexp 0|false|off|no $valid])} {
  572.         uplevel #0 $itk_option(-invalid)
  573.         return -code break 0
  574.     }
  575.     }
  576.     
  577.     return -code continue 1
  578. }
  579.  
  580. # ------------------------------------------------------------------
  581. # PRIVATE METHOD: _checkLength
  582. #
  583. # This method was added by csmith for SF ticket 227912. We need to
  584. # to check the clipboard content before allowing any pasting into
  585. # the entryfield to disallow text that is longer than the value
  586. # specified by the -fixed option.
  587. # ------------------------------------------------------------------
  588. itcl::body iwidgets::Entryfield::_checkLength {} {
  589.   if {$itk_option(-fixed) != 0} {
  590.     if [catch {::selection get -selection CLIPBOARD} pending] {
  591.       # Nothing in the clipboard.  Check the primary selection.
  592.       if [catch {::selection get -selection PRIMARY} pending] {
  593.         # Nothing here either.  Goodbye.
  594.         return
  595.       }
  596.     }
  597.     set len [expr {[string length $pending] + [string length [get]]}]
  598.     if {$len > $itk_option(-fixed)} {
  599.       uplevel #0 $itk_option(-invalid)
  600.       return -code break 0
  601.     }
  602.   }
  603. }
  604.