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 / regexpfield.itk < prev    next >
Encoding:
Text File  |  2003-09-01  |  14.9 KB  |  456 lines
  1. #
  2. # Regexpfield
  3. # ----------------------------------------------------------------------
  4. # Implements a text entry widget which accepts input that matches its
  5. # regular expression, and invalidates input which doesn't.
  6. # 
  7. #
  8. # ----------------------------------------------------------------------
  9. #   AUTHOR:  John A. Tucker           E-mail: jatucker@austin.dsccc.com
  10. #
  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 Regexpfield {
  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::Regexpfield {
  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 -regexp regexp Regexp {.*}
  60.     itk_option define -nocase nocase Nocase 0
  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.     protected {
  76.     method _focusCommand {}
  77.     method _keyPress {char sym state}
  78.     }
  79.  
  80.     private {
  81.     method _peek {char}
  82.     }
  83. }
  84.  
  85. #
  86. # Provide a lowercased access method for the Regexpfield class.
  87. # 
  88. proc ::iwidgets::regexpfield {pathName args} {
  89.     uplevel ::iwidgets::Regexpfield $pathName $args
  90. }
  91.  
  92. # ------------------------------------------------------------------
  93. #                        CONSTRUCTOR
  94. # ------------------------------------------------------------------
  95. itcl::body iwidgets::Regexpfield::constructor {args} {
  96.     component hull configure -borderwidth 0
  97.     
  98.     itk_component add entry {
  99.     entry $itk_interior.entry
  100.     } {
  101.     keep -borderwidth -cursor -exportselection \
  102.         -foreground -highlightcolor \
  103.         -highlightthickness -insertbackground -insertborderwidth \
  104.         -insertofftime -insertontime -insertwidth -justify \
  105.         -relief -selectbackground -selectborderwidth \
  106.         -selectforeground -show -state -textvariable -width
  107.     
  108.     rename -font -textfont textFont Font
  109.     rename -highlightbackground -background background Background
  110.     rename -background -textbackground textBackground Background
  111.     }
  112.     
  113.     #
  114.     # Create the child site widget.
  115.     #
  116.     itk_component add -protected efchildsite {
  117.     frame $itk_interior.efchildsite
  118.     } 
  119.     set itk_interior $itk_component(efchildsite)
  120.     
  121.     #
  122.     # Regexpfield instance bindings.
  123.     #
  124.     bind $itk_component(entry) <KeyPress> [itcl::code $this _keyPress %A %K %s]
  125.     bind $itk_component(entry) <FocusIn> [itcl::code $this _focusCommand]
  126.     
  127.     #
  128.     # Initialize the widget based on the command line options.
  129.     #
  130.     eval itk_initialize $args
  131. }
  132.  
  133. # ------------------------------------------------------------------
  134. #                             OPTIONS
  135. # ------------------------------------------------------------------
  136.  
  137. # ------------------------------------------------------------------
  138. # OPTION: -command
  139. #
  140. # Command associated upon detection of Return key press event
  141. # ------------------------------------------------------------------
  142. itcl::configbody iwidgets::Regexpfield::command {}
  143.  
  144. # ------------------------------------------------------------------
  145. # OPTION: -focuscommand
  146. #
  147. # Command associated upon detection of focus.
  148. # ------------------------------------------------------------------
  149. itcl::configbody iwidgets::Regexpfield::focuscommand {}
  150.  
  151. # ------------------------------------------------------------------
  152. # OPTION: -regexp
  153. #
  154. # Specify a regular expression to use in performing validation
  155. # of the content of the entry widget.
  156. # ------------------------------------------------------------------
  157. itcl::configbody iwidgets::Regexpfield::regexp {
  158. }
  159.  
  160. # ------------------------------------------------------------------
  161. # OPTION: -invalid
  162. #
  163. # Specify a command to executed should the current Regexpfield contents
  164. # be proven invalid.
  165. # ------------------------------------------------------------------
  166. itcl::configbody iwidgets::Regexpfield::invalid {}
  167.  
  168. # ------------------------------------------------------------------
  169. # OPTION: -fixed
  170. #
  171. # Restrict entry to 0 (unlimited) chars.  The value is the maximum 
  172. # number of chars the user may type into the field, regardles of 
  173. # field width, i.e. the field width may be 20, but the user will 
  174. # only be able to type -fixed number of characters into it (or 
  175. # unlimited if -fixed = 0).
  176. # ------------------------------------------------------------------
  177. itcl::configbody iwidgets::Regexpfield::fixed {
  178.     if {[regexp {[^0-9]} $itk_option(-fixed)] || \
  179.         ($itk_option(-fixed) < 0)} {
  180.     error "bad fixed option \"$itk_option(-fixed)\",\
  181.         should be positive integer"
  182.     }
  183. }
  184.  
  185. # ------------------------------------------------------------------
  186. # OPTION: -childsitepos
  187. #
  188. # Specifies the position of the child site in the widget.
  189. # ------------------------------------------------------------------
  190. itcl::configbody iwidgets::Regexpfield::childsitepos {
  191.     set parent [winfo parent $itk_component(entry)]
  192.  
  193.     switch $itk_option(-childsitepos) {
  194.     n {
  195.         grid $itk_component(efchildsite) -row 0 -column 0 -sticky ew
  196.         grid $itk_component(entry) -row 1 -column 0 -sticky nsew
  197.  
  198.         grid rowconfigure $parent 0 -weight 0
  199.         grid rowconfigure $parent 1 -weight 1
  200.         grid columnconfigure $parent 0 -weight 1
  201.         grid columnconfigure $parent 1 -weight 0
  202.     }
  203.     
  204.     e {
  205.         grid $itk_component(efchildsite) -row 0 -column 1 -sticky ns
  206.         grid $itk_component(entry) -row 0 -column 0 -sticky nsew
  207.  
  208.         grid rowconfigure $parent 0 -weight 1
  209.         grid rowconfigure $parent 1 -weight 0
  210.         grid columnconfigure $parent 0 -weight 1
  211.         grid columnconfigure $parent 1 -weight 0
  212.     }
  213.     
  214.     s {
  215.         grid $itk_component(efchildsite) -row 1 -column 0 -sticky ew
  216.         grid $itk_component(entry) -row 0 -column 0 -sticky nsew
  217.  
  218.         grid rowconfigure $parent 0 -weight 1
  219.         grid rowconfigure $parent 1 -weight 0
  220.         grid columnconfigure $parent 0 -weight 1
  221.         grid columnconfigure $parent 1 -weight 0
  222.     }
  223.     
  224.     w {
  225.         grid $itk_component(efchildsite) -row 0 -column 0 -sticky ns
  226.         grid $itk_component(entry) -row 0 -column 1 -sticky nsew
  227.  
  228.         grid rowconfigure $parent 0 -weight 1
  229.         grid rowconfigure $parent 1 -weight 0
  230.         grid columnconfigure $parent 0 -weight 0
  231.         grid columnconfigure $parent 1 -weight 1
  232.     }
  233.     
  234.     default {
  235.         error "bad childsite option\
  236.             \"$itk_option(-childsitepos)\":\
  237.             should be n, e, s, or w"
  238.     }
  239.     }
  240. }
  241. # ------------------------------------------------------------------
  242. # OPTION: -nocase
  243. #
  244. # Specifies whether or not lowercase characters can match either
  245. # lowercase or uppercase letters in string.
  246. # ------------------------------------------------------------------
  247. itcl::configbody iwidgets::Regexpfield::nocase {
  248.  
  249.     switch $itk_option(-nocase) {
  250.     0 - 1 {
  251.  
  252.     }
  253.     
  254.     default {
  255.         error "bad nocase option \"$itk_option(-nocase)\":\
  256.             should be 0 or 1"
  257.     }
  258.     }
  259. }
  260.  
  261. # ------------------------------------------------------------------
  262. #                            METHODS
  263. # ------------------------------------------------------------------
  264.  
  265. # ------------------------------------------------------------------
  266. # METHOD: childsite
  267. #
  268. # Returns the path name of the child site widget.
  269. # ------------------------------------------------------------------
  270. itcl::body iwidgets::Regexpfield::childsite {} {
  271.     return $itk_component(efchildsite)
  272. }
  273.  
  274. # ------------------------------------------------------------------
  275. # METHOD: get 
  276. #
  277. # Thin wrap of the standard entry widget get method.
  278. # ------------------------------------------------------------------
  279. itcl::body iwidgets::Regexpfield::get {} {
  280.     return [$itk_component(entry) get]
  281. }
  282.  
  283. # ------------------------------------------------------------------
  284. # METHOD: delete
  285. #
  286. # Thin wrap of the standard entry widget delete method.
  287. # ------------------------------------------------------------------
  288. itcl::body iwidgets::Regexpfield::delete {args} {
  289.     return [eval $itk_component(entry) delete $args]
  290. }
  291.  
  292. # ------------------------------------------------------------------
  293. # METHOD: icursor 
  294. #
  295. # Thin wrap of the standard entry widget icursor method.
  296. # ------------------------------------------------------------------
  297. itcl::body iwidgets::Regexpfield::icursor {args} {
  298.     return [eval $itk_component(entry) icursor $args]
  299. }
  300.  
  301. # ------------------------------------------------------------------
  302. # METHOD: index 
  303. #
  304. # Thin wrap of the standard entry widget index method.
  305. # ------------------------------------------------------------------
  306. itcl::body iwidgets::Regexpfield::index {args} {
  307.     return [eval $itk_component(entry) index $args]
  308. }
  309.  
  310. # ------------------------------------------------------------------
  311. # METHOD: insert 
  312. #
  313. # Thin wrap of the standard entry widget index method.
  314. # ------------------------------------------------------------------
  315. itcl::body iwidgets::Regexpfield::insert {args} {
  316.     return [eval $itk_component(entry) insert $args]
  317. }
  318.  
  319. # ------------------------------------------------------------------
  320. # METHOD: scan 
  321. #
  322. # Thin wrap of the standard entry widget scan method.
  323. # ------------------------------------------------------------------
  324. itcl::body iwidgets::Regexpfield::scan {args} {
  325.     return [eval $itk_component(entry) scan $args]
  326. }
  327.  
  328. # ------------------------------------------------------------------
  329. # METHOD: selection
  330. #
  331. # Thin wrap of the standard entry widget selection method.
  332. # ------------------------------------------------------------------
  333. itcl::body iwidgets::Regexpfield::selection {args} {
  334.     return [eval $itk_component(entry) selection $args]
  335. }
  336.  
  337. # ------------------------------------------------------------------
  338. # METHOD: xview 
  339. #
  340. # Thin wrap of the standard entry widget xview method.
  341. # ------------------------------------------------------------------
  342. itcl::body iwidgets::Regexpfield::xview {args} {
  343.     return [eval $itk_component(entry) xview $args]
  344. }
  345.  
  346. # ------------------------------------------------------------------
  347. # METHOD: clear 
  348. #
  349. # Delete the current entry contents.
  350. # ------------------------------------------------------------------
  351. itcl::body iwidgets::Regexpfield::clear {} {
  352.     $itk_component(entry) delete 0 end
  353.     icursor 0
  354. }
  355.  
  356. # ------------------------------------------------------------------
  357. # PRIVATE METHOD: _peek char
  358. #
  359. # The peek procedure returns the value of the Regexpfield with the
  360. # char inserted at the insert position.
  361. # ------------------------------------------------------------------
  362. itcl::body iwidgets::Regexpfield::_peek {char} {
  363.     set str [get]
  364.  
  365.     set insertPos [index insert] 
  366.     set firstPart [string range $str 0 [expr {$insertPos - 1}]]
  367.     set lastPart [string range $str $insertPos end]
  368.  
  369.     append rtnVal $firstPart $char $lastPart
  370.     return $rtnVal
  371. }
  372.  
  373. # ------------------------------------------------------------------
  374. # PROTECTED METHOD: _focusCommand
  375. #
  376. # Method bound to focus event which evaluates the current command
  377. # specified in the focuscommand option
  378. # ------------------------------------------------------------------
  379. itcl::body iwidgets::Regexpfield::_focusCommand {} {
  380.     uplevel #0 $itk_option(-focuscommand)
  381. }
  382.  
  383. # ------------------------------------------------------------------
  384. # PROTECTED METHOD: _keyPress 
  385. #
  386. # Monitor the key press event checking for return keys, fixed width
  387. # specification, and optional validation procedures.
  388. # ------------------------------------------------------------------
  389. itcl::body iwidgets::Regexpfield::_keyPress {char sym state} {
  390.     #
  391.     # A Return key invokes the optionally specified command option.
  392.     #
  393.     if {$sym == "Return"} {
  394.     uplevel #0 $itk_option(-command)
  395.     return -code break 1
  396.     } 
  397.     
  398.     #
  399.     # Tabs, BackSpace, and Delete are passed on for other bindings.
  400.     #
  401.     if {($sym == "Tab") || ($sym == "BackSpace") || ($sym == "Delete")} {
  402.     return -code continue 1
  403.     }
  404.     
  405.     # 
  406.     # Character is not printable or the state is greater than one which
  407.     # means a modifier was used such as a control, meta key, or control
  408.     # or meta key with numlock down.
  409.     #
  410.     if {($char == "") || \
  411.         ($state == 4) || ($state == 8) || \
  412.         ($state == 36) || ($state == 40)} {
  413.     return -code continue 1
  414.     }
  415.  
  416.     #
  417.     # If the fixed length option is not zero, then verify that the
  418.     # current length plus one will not exceed the limit.  If so then
  419.     # invoke the invalid command procedure.
  420.     #
  421.     if {$itk_option(-fixed) != 0} {
  422.     if {[string length [get]] >= $itk_option(-fixed)} {
  423.         uplevel #0 $itk_option(-invalid)
  424.         return -code break 0
  425.     }
  426.     } 
  427.  
  428.     set flags ""
  429.  
  430.     #
  431.     # Get the new value of the Regexpfield with the char inserted at the
  432.     # insert position.
  433.     #
  434.     # If the new value doesn't match up with the pattern stored in the
  435.     # -regexp option, then the invalid procedure is called.
  436.     #
  437.     # If the value of the "-nocase" option is true, then add the
  438.     # "-nocase" flag to the list of flags.
  439.     #
  440.     set newVal [_peek $char]
  441.  
  442.     if {$itk_option(-nocase)} {
  443.     set valid [::regexp -nocase -- $itk_option(-regexp) $newVal]
  444.     } else {
  445.     set valid [::regexp $itk_option(-regexp) $newVal]
  446.     }
  447.  
  448.     if {!$valid} {
  449.     uplevel #0 $itk_option(-invalid)
  450.     return -code break 0
  451.     }
  452.  
  453.     return -code continue 1
  454. }
  455.  
  456.