home *** CD-ROM | disk | FTP | other *** search
/ PCNET 2006 September - Disc 1 / PCNET_CD_2006_09.iso / linux / puppy-barebones-2.01r2.iso / pup_201.sfs / usr / lib / regexpviewer / regexpviewer.tcl < prev    next >
Encoding:
Text File  |  2004-03-23  |  9.1 KB  |  355 lines
  1. # regexpviewer.tcl -- regular expression viewer
  2.  
  3. # Copyright 2004 David N. Welton <davidw@dedasys.com>
  4.  
  5. # $Id: regexpviewer.tcl,v 1.1.1.1 2004/03/23 21:04:21 davidw Exp $
  6.  
  7. package require Tk
  8. package require msgcat
  9. namespace import msgcat::*
  10.  
  11. set auto_path [linsert $auto_path 0 .]
  12. package require style::lobster
  13. package require gridinfo
  14. package require about
  15. namespace import gridinfo::*
  16.  
  17. namespace eval review {
  18.     variable matchall
  19. }
  20.  
  21. # review::getopts --
  22. #
  23. #    Get options to insert into regexp command.
  24.  
  25. proc review::getopts {} {
  26.     set vars {all nocase linestop line lineanchor}
  27.     set retval {}
  28.     foreach v $vars {
  29.     variable $v
  30.     if { [set $v] == 1 } {
  31.         lappend retval -$v
  32.     }
  33.     }
  34.     return $retval
  35. }
  36.  
  37. namespace eval review::gui {
  38.     variable neutralbg "\#999999"
  39.     variable errbg "\#dd0000"
  40.     variable matchcolor "\#00dd00"
  41.     variable matchbg "\#99dd99"
  42.     variable hlcolor "\#9999ff"
  43.     variable led
  44.     variable matchl
  45.     wm title . "regexp viewer"
  46.  
  47.     font create FixedFont -size -12 -family Courier
  48.  
  49.     menu .mbar
  50.     . config -menu .mbar
  51.  
  52.     .mbar add cascade -label [mc "File"] -underline 0 \
  53.     -menu [menu .mbar.file -tearoff 0]
  54.  
  55.     .mbar add cascade -label [mc "Options"] -underline 0 \
  56.     -menu [menu .mbar.options -tearoff 0]
  57.  
  58.     .mbar add command -label [mc "About"] -underline 0 \
  59.     -command review::gui::about
  60.  
  61.     set FMenu .mbar.file
  62.     set OMenu .mbar.options
  63.  
  64.     $FMenu add command -label [mc "Load Text"] -underline 0 \
  65.     -command review::gui::loadtext
  66. #    $FMenu add command -label [mc "Save File"] -underline 0 \
  67. #    -command review::gui::savefile
  68.     $FMenu add command -label [mc "Exit"] -underline 0 \
  69.     -command review::gui::quit
  70.  
  71.     $OMenu add check -label "Match All" -variable review::all
  72.     $OMenu add check -label "No Case" -variable review::nocase
  73.     $OMenu add check -label "Line Stop" -variable review::linestop
  74.     $OMenu add check -label "Newline Sensitive" -variable review::line
  75.     $OMenu add check -label "Line Anchor" -variable review::lineanchor
  76.  
  77.     # text frame.
  78.     . configure -padx 8
  79.     . configure -pady 4
  80.     labelframe .txtframe -text "Text"
  81.     variable text [text .txtframe.txt -height 5 -font FixedFont \
  82.                -yscrollcommand [list .txtframe.scroll set]]
  83.     set textscroll [scrollbar .txtframe.scroll -command [list $text yview]]
  84.     bind $text <Key> [list review::gui::altered]
  85.  
  86.     # regular expression frame.
  87.     labelframe .reframe -text "Regular Expression"
  88.     variable re [text .reframe.re -height 2 -font FixedFont \
  89.              -yscrollcommand [list .reframe.scroll set]]
  90.     set rescroll [scrollbar .reframe.scroll -command [list $re yview]]
  91.     bind $re <Key> [list review::gui::altered]
  92.  
  93.     # match frame
  94.     labelframe .matchframe -text "Match"
  95.     set matchl [label .matchframe.ml -text "" -justify left]
  96.     set led [canvas .matchframe.mc -height 32 -width 32]
  97.     .matchframe.mc create oval 4 4 28 28
  98.     .matchframe.mc itemconfigure 1 -fill $neutralbg
  99.  
  100.     set run [button .run -text "Execute Regular Expression" \
  101.          -command review::gui::run]
  102.  
  103.     # grid text frame
  104.     grid .txtframe -sticky news -columnspan 2 -padx 5 -pady 3
  105.     grid $text $textscroll -sticky news
  106.     grid columnconfigure .txtframe [column $text] -weight 1
  107.     grid rowconfigure .txtframe [row $text] -weight 1
  108.  
  109.     # grid re frame
  110.     grid .reframe -sticky news -columnspan 2  -padx 5 -pady 3
  111.     grid $re $rescroll -sticky news
  112.     grid columnconfigure .reframe [column $re] -weight 1
  113.     grid rowconfigure .reframe [row $re] -weight 1
  114.  
  115.     # grid match frame
  116.     grid .matchframe $run -sticky nws  -padx 5 -pady 3
  117.     grid configure $run -sticky nes
  118.     grid .matchframe.mc .matchframe.ml -sticky nws
  119.  
  120.     grid columnconfigure . [column .matchframe] -weight 1
  121.     grid rowconfigure . [row .txtframe] -weight 5
  122.     grid rowconfigure . [row .reframe] -weight 5
  123. #    grid rowconfigure . [row .matchframe] -weight 1
  124. }
  125.  
  126. # review::gui::run --
  127. #
  128. #    Run the text through the regular expression.
  129.  
  130. proc review::gui::run {} {
  131.     variable text
  132.     variable re
  133.     set txt [string trimright [$text get 0.0 end]]
  134.     set rexp [string trimright [$re get 0.0 end]]
  135.     if { [catch {
  136.     set regexp "regexp [review::getopts] -inline -indices -- {$rexp} {$txt}"
  137.     #puts $regexp
  138.     set resl [eval $regexp]
  139.     } err] } {
  140.     review::gui::nomatch $err
  141.     return
  142.     }
  143.     #puts "Results $resl"
  144.     if { [llength $resl] < 1 } {
  145.     review::gui::nomatch
  146.     } else {
  147.     review::gui::match $resl
  148.     }
  149. }
  150.  
  151. # review::gui::nomatch --
  152. #
  153. #    This is called when there is no match, either because of an
  154. #    error (1 arg) or because the regexp just doesn't match (no
  155. #    args).
  156.  
  157. proc review::gui::nomatch {args} {
  158.     variable errbg
  159.     variable led
  160.     variable matchl
  161.     variable text
  162.  
  163.     $led itemconfigure 1 -fill $errbg
  164.     if { [llength $args] != 0 } {
  165.     $matchl configure -text "Error:\n[lindex $args 0]"
  166.     } else {
  167.     $matchl configure -text "No match"
  168.     }
  169.     $text tag delete allmatch
  170. }
  171.  
  172. # review::gui::match --
  173. #
  174. #    This is called when the regexp matches.  As a side effect, it
  175. #    creates tags in the text text widget and the regexp text
  176. #    widget.
  177.  
  178. proc review::gui::match {indices} {
  179.     variable led
  180.     variable matchl
  181.     variable matchbg
  182.     variable matchcolor
  183.     variable text
  184.     variable re
  185.     $led itemconfigure 1 -fill $matchcolor
  186.     $matchl configure -text "Match"
  187.     array set matches [review::gui::creatematchbindings \
  188.               [string trimright [$re get 0.0 end]]]
  189.     set matchnum [array size matches]
  190.  
  191.     set x 0
  192.     # We loop through each set of matches, which is equivalent to
  193.     # entirematch match1 match2 matchN
  194.     while { $x < [llength $indices] } {
  195.     # This is the entire match part.
  196.     foreach {start end} [lindex $indices $x] {break}
  197.     incr end
  198.     $text tag add allmatch "1.0 + $start chars" "1.0 + $end chars"
  199.     $text tag configure allmatch -background $matchbg
  200.     set i 1
  201.     # Now loop through the indices of the matches in the text, and
  202.     # mark them up.
  203.     foreach {idx} [lrange $indices [expr {$x + 1}] [expr {$x + $matchnum}]] {
  204.         set start [lindex $idx 0]
  205.         set end [lindex $idx 1]
  206.         incr end
  207.         $text tag add match$i "1.0 + $start chars" "1.0 + $end chars"
  208.         incr i
  209.     }
  210.  
  211.     set i 1
  212.     # Now loop through the () expressions in the regexp itself and
  213.     # set them up.
  214.     foreach {m idxs} [array get matches] {
  215.         set start [lindex $idxs 0]
  216.         set end [lindex $idxs 1]
  217.         incr end
  218.         $re tag add rematch$i "1.0 + $start chars" "1.0 + $end chars"
  219.         $re tag bind rematch$i <Motion> [list review::gui::showtag rematch$i match$i]
  220.         $re tag bind rematch$i <Leave> [list review::gui::showtag rematch$i]
  221.         incr i
  222.     }
  223.     incr x
  224.     incr x $matchnum
  225.     }
  226. }
  227.  
  228.  
  229. # review::gui::creatematchbindings --
  230. #
  231. #    Gets the indexes of matching parenthesis in a regexp, so that
  232. #    we can highlight sub-matches.
  233.  
  234. proc review::gui::creatematchbindings {rexp} {
  235.     variable re
  236.     variable text
  237.     variable hlcolor
  238.     set i 0
  239.     set relen [string length $rexp]
  240.     array set matches {}
  241.     set matchno 1
  242.     while {$i < $relen} {
  243.     switch -exact -- [string index $rexp $i] {
  244.         "\\" {
  245.         set next [string index $rexp [expr {$i + 1}]]
  246.         if { $next == "(" || $next == ")" } {
  247.             incr i
  248.         }
  249.         }
  250.         "(" {
  251.         lappend matchstack $matchno
  252.         lappend matches($matchno) $i
  253.         incr matchno
  254.         }
  255.         ")" {
  256.         set tmpmatchno [lindex $matchstack end]
  257.         lappend matches($tmpmatchno) $i
  258.         set matchstack [lreplace $matchstack end end]
  259.         }
  260.         default {}
  261.     }
  262.     incr i
  263.     }
  264.     return [array get matches]
  265. }
  266.  
  267. # review::gui::showtag --
  268. #
  269. #    This is the binding called when the mouse goes over the paren
  270. #    regions in the regexp.
  271.  
  272. proc review::gui::showtag {args} {
  273.     variable re
  274.     variable text
  275.     variable matchbg
  276.     variable hlcolor
  277.     set tagname [lindex $args 1]
  278.     set retag [lindex $args 0]
  279.     foreach tag [$text tag names] {
  280.     if { [string match "match*" $tag] } {
  281.         $text tag configure $tag -background $matchbg
  282.     }
  283.     }
  284.     foreach tag [$re tag names] {
  285.     if { [string match "rematch*" $tag] } {
  286.         $re tag configure $tag -background white
  287.     }
  288.     }
  289.  
  290.     if {$tagname != "" } {
  291.     $text tag configure $tagname -background $hlcolor
  292.     $text tag raise $tagname
  293.     $re tag configure $retag -background $hlcolor
  294.     }
  295. }
  296.  
  297. # review::gui::altered --
  298. #
  299. #    This is the binding called when the text or regexp is
  300. #    modified.  It wipes out all the 'match' stuff.
  301.  
  302. proc review::gui::altered {} {
  303.     variable text
  304.     variable re
  305.     variable led
  306.     variable matchl
  307.     variable neutralbg
  308.  
  309.     foreach tag [$text tag names] {
  310.     if { [string match "match*" $tag] || $tag == "allmatch" } {
  311.         $text tag delete $tag
  312.     }
  313.     }
  314.     foreach tag [$re tag names] {
  315.     if { [string match "rematch*" $tag] } {
  316.         $re tag delete $tag
  317.     }
  318.     }
  319.  
  320.     $led itemconfigure 1 -fill $neutralbg
  321.     $matchl configure -text ""
  322. }
  323.  
  324. # review::gui::loadtext --
  325. #
  326. #    Loads a file into the text text widget.
  327.  
  328. proc review::gui::loadtext {} {
  329.     variable text
  330.     set fn [tk_getOpenFile]
  331.     if { $fn == "" } { return }
  332.     set fl [open $fn]
  333.     set data [read $fl]
  334.     close $fl
  335.     $text delete 0.0 end
  336.     $text insert end $data
  337. }
  338.  
  339. # review::gui::about --
  340. #
  341. #    About dialog.
  342.  
  343. proc review::gui::about {} {
  344.     about::about "regexpviewer" "David N. Welton <davidw@dedasys.com>" {
  345.     "Visit http://dedasys.com for other programs!"
  346.     }
  347. }
  348.  
  349. # review::gui::quit --
  350. #
  351. #    See if you can figure this one out for yourselves:-)
  352.  
  353. proc review::gui::quit {} {
  354.     exit
  355. }