1#!/usr/local/bin/wish8.6 2 3set version 3.0 4 5############################################################################################### 6# 7# VisualREGEXP -- A graphical front-end to wirte/debug regular expression 8# (c) 2000-2002 Laurent Riesterer 9# 10# VisualREGEXP Home Page: http://laurent.riesterer.free.fr/regexp 11# 12#---------------------------------------------------------------------------------------------- 13# 14# Usage: tkregexp <sampleFile> 15# 16#---------------------------------------------------------------------------------------------- 17# 18# This program is free software; you can redistribute it and/or modify 19# it under the terms of the GNU General Public License as published by 20# the Free Software Foundation; either version 2 of the License, or 21# (at your option) any later version. 22# 23# This program is distributed in the hope that it will be useful, 24# but WITHOUT ANY WARRANTY; without even the implied warranty of 25# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 26# GNU General Public License for more details. 27# 28# You should have received a copy of the GNU General Public License 29# along with this program; if not, write to the Free Software 30# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 31# 32############################################################################################### 33 34 35 36#---------------------------------------------------------------------------------------------- 37# SOME CUSTOMIZATION CAN BE DONE BY MODIFYING VARIABLES BELOW 38#---------------------------------------------------------------------------------------------- 39 40# main font used to display the text 41if {$tcl_platform(platform) == "windows"} { 42 set font_regexp {Courier 10} 43 set font_replace {Courier 10} 44 set font_sample {Courier 10} 45} else { 46 set font_regexp 9x15 47 set font_replace 9x15 48 set font_sample 9x15 49} 50# the font used in the popup menu (use ---- to get a separator, else format is {font size ?bold?} 51set fonts {{Courier 8} {Courier 9} {Courier 10} {Courier 11} {Courier 12} 52 ---- 53 {Arial 8} {Arial 9} {Arial 10} {Arial 11} {Arial 12} 54 ---- 55 8x13 8x13bold 9x15 9x15bold 10x20} 56# the colors for the different matching groups 57set colors {#ff0000 #0000ff darkgreen violetred #ff9000 #537db9 #e4c500 firebrick darkgoldenrod hotpink} 58set bgcolors {#ffe6e6 #e6e6ff #e6ffe6 #efd5e1 #fef3e5 #d6dce5 lightyellow white white white} 59# use background color in sample by default ? (1 use, 0 do not use) 60set background 1 61# background color to visualize the non-reporting group (?:...) 62set color_noreport #fffdc4 63# background color to visualize the lookhead group (?=...) and (?!...) 64set color_lookahead wheat 65# show/hide help about control characters in regexp 66set show_help 0 67# show/hide history windows on startup 68set history 0 69# mode to use on startup (select/concat = raw, select/insert new lines = nl, replace = replace) 70set mode nl 71# database of some regexp to appear in the "Insert regexp" menu 72set regexp_db { 73 "URL" {(?:^|")(http|ftp|mailto):(?://)?(\w+(?:[\.:@]\w+)*?)(?:/|@)([^"\?]*?)(?:\?([^\?"]*?))?(?:$|")} 74 "IP numbers" {[12]?[0-9]?[0-9](\.[12]?[0-9]?[0-9]){3}} 75 "HTML tags" {<[^<>]+>} 76 "HTML tag content" {<(\w+)[^>]*?>(.*?)</\1>} 77 "vars and arrays (PHP)" {\$[^0-9 ]{1}[a-zA-Z0-9_]*((?:\[[a-zA-Z0-9_'\"]+\])*)} 78 "dd/mm/yyyy" {(0[1-9]|[12][0-9]|3[01])(/|-)(0[1-9]|1[12])(/|-)[12][0-9]{3}} 79 "mm/dd/yyyy" {(0[1-9]|1[12])(/|-)(0[1-9]|[12][0-9]|3[01])(/|-)[12][0-9]{3}} 80 "hh:mm" {([01][0-9]|2[0-3]):[0-5][0-9]} 81 "user@domain.net" {[A-Za-z0-9_.-]+@([A-Za-z0-9_]+\.)+[A-Za-z]{2,4}} 82} 83 84# " 85#---------------------------------------------------------------------------------------------- 86# DO NOT MODIFY BELOW THIS POINT 87#---------------------------------------------------------------------------------------------- 88 89namespace eval regexp {} { 90 set data(v:undo:index) 0 91 set data(v:undo:sample) "" 92 set data(v:dir) "." 93 set data(v:file) "untitled.txt" 94 95 set data(v:dumpToConsole) 0; 96 set data(v:dumpToClipboard) 0; 97} 98 99#---------------------------------------------------------------------------------------------- 100# Main GUI 101#---------------------------------------------------------------------------------------------- 102 103proc regexp::gui {} { 104variable data 105global colors bgcolors color_noreport color_lookahead show_help regexp_db history 106global tcl_platform 107 108 wm withdraw .; 109 110 panedwindow .top -orient vertical -showhandle 1; 111 112 # frame for regexp 113 # 114 labelframe .top.regexp -text "pattern" -borderwidth 2 -relief groove; 115 # text for regexp entry 116 # 117 frame .top.regexp.pattern; 118 119 set data(w:regexp) [text .top.regexp.pattern.text \ 120 -wrap char \ 121 -undo 1 \ 122 -background white \ 123 -font $::font_regexp \ 124 -selectbackground lightblue \ 125 -selectborderwidth 0 \ 126 -width 80 \ 127 -height 5 \ 128 -borderwidth 1 \ 129 -yscrollcommand [list .top.regexp.pattern.sy set] \ 130 -xscrollcommand [list .top.regexp.pattern.sx set] \ 131 ]; 132 scrollbar .top.regexp.pattern.sy \ 133 -command ".top.regexp.pattern.text yview" \ 134 -orient vertical \ 135 -borderwidth 1; 136 scrollbar .top.regexp.pattern.sx \ 137 -command ".top.regexp.pattern.text xview" \ 138 -orient horizontal \ 139 -borderwidth 1; 140 grid .top.regexp.pattern.text .top.regexp.pattern.sy -sticky news 141 grid .top.regexp.pattern.sx x -sticky news 142 grid columnconfigure .top.regexp.pattern 0 -weight 1; 143 grid rowconfigure .top.regexp.pattern 0 -weight 1; 144 145 # options 146 # 147 set sep 0; 148 149 frame .top.regexp.options; 150 151 foreach \ 152 option {nocase all - line lineanchor linestop - inline} \ 153 label {nocase all - line "lineanchor (k)" "linestop (m)" - inline} \ 154 underline {0 0 - 0 12 10 - 0} \ 155 { 156 if {$option != "-"} { 157 checkbutton .top.regexp.options.$option \ 158 -text $label \ 159 -borderwidth 1 \ 160 -underline $underline \ 161 -variable regexp::data(v:$option) \ 162 -offvalue "" \ 163 -tristatevalue "never_ever_used" \ 164 -onvalue "-$option"; 165 166 set data(v:$option) " "; 167 168 pack .top.regexp.options.$option -side left; 169 } else { 170 pack [frame .top.regexp.options.[incr sep] -width 40] -fill x -side left -expand 1; 171 } 172 } 173 174 if {$tcl_platform(platform) == "windows"} { 175 set sfont {Courier 8}; 176 set sbfont {Courier 8 bold}; 177 } else { 178 set sfont 6x13; 179 set sbfont 6x13bold; 180 } 181 182 set data(w:help) [text .top.regexp.help \ 183 -font $sfont \ 184 -borderwidth 0 \ 185 -height 9 \ 186 -wrap none \ 187 -background [.top.regexp cget -background] \ 188 ]; 189 190 .top.regexp.help insert 1.0 "\n\n\n\n\n\n\n\n"; 191 .top.regexp.help insert 1.0 {\a alert \n newline \0 char 0 \d [[:digit:]] \A beginning of the string }; 192 .top.regexp.help insert 2.0 {\b backspace \r carriage \xyz octal code \D [^[:digit:]] \Z end of string }; 193 .top.regexp.help insert 3.0 {\B synomyn for \ \t tab \s [[:space:]] \m beginning of a word}; 194 .top.regexp.help insert 4.0 {\cX same as X & 0x1F \uwxyz unicode \x backref \S [^[:space:]] \M end of a word}; 195 .top.regexp.help insert 5.0 {\e ESC \v vert tab \w [[:alnum:]_] \y beginning or end of a word}; 196 .top.regexp.help insert 6.0 {\f form feed \xhhh hexa code \W [^[:alnum:]_] \Y not beginning or end of a word}; 197 .top.regexp.help insert 7.0 {----------------------------------------------------------------------------------------------------------------}; 198 .top.regexp.help insert 8.0 { ungreedy: ?? single optional *? zero-many +? at least one {n,m}? ungreedy quantifiers}; 199 .top.regexp.help insert 9.0 {(?:) ghost group (?=) lookahead (?!) neg. lookahead}; 200 201 .top.regexp.help tag configure bold -font $sbfont; 202 203 foreach line {1 2 3 4 5 6} { 204 foreach {min max} {0 2 23 25 42 44 61 63 79 82} { 205 .top.regexp.help tag add bold $line.$min $line.$max; 206 } 207 } 208 209 .top.regexp.help tag remove bold 2.43 2.44 4.43 4.44; 210 211 # buttons & selection of match 212 # 213 frame .top.regexp.buttons; 214 button .top.regexp.buttons.go \ 215 -text "Go" \ 216 -underline 0 \ 217 -command { 218 # puts regexp 219 # 220 if {($regexp::data(v:dumpToConsole) == 1) || 221 ($regexp::data(v:dumpToClipboard) == 1)} { 222 regexp::dump; 223 } 224 225 regexp::go 226 } \ 227 -borderwidth 1 \ 228 -width 8; 229 button .top.regexp.buttons.clear \ 230 -text "Clear (z)" \ 231 -underline 7 \ 232 -command [list regexp::clear] \ 233 -borderwidth 1 \ 234 -width 8; 235 pack .top.regexp.buttons.go -side left -padx {0 5} -pady 5; 236 pack .top.regexp.buttons.clear -side left -padx 5 -pady 5; 237 238 # selection - buttons for match level 239 # 240 label .top.regexp.buttons.sep; 241 label .top.regexp.buttons.l -text "Select:"; 242 pack .top.regexp.buttons.sep -side left -fill x -expand true; 243 pack .top.regexp.buttons.l -side left -padx 5 -pady 5; 244 245 set i 0; 246 247 foreach c $colors t {match 1 2 3 4 5 6 7 8 9} { 248 button .top.regexp.buttons.$i \ 249 -text $t \ 250 -foreground $c \ 251 -borderwidth 1 \ 252 -padx 0 \ 253 -width 6 \ 254 -command [list regexp::select $i]; 255 256 pack .top.regexp.buttons.$i -side left -fill y -pady 5; 257 258 incr i; 259 } 260 261 # text for replace 262 # 263 set data(w:allreplace) [frame .top.regexp.replace]; 264 frame .top.regexp.replace.result; 265 set data(w:replace) [text .top.regexp.replace.result.text \ 266 -wrap char \ 267 -undo 1 \ 268 -background white \ 269 -font $::font_replace \ 270 -selectbackground lightblue \ 271 -selectborderwidth 0 \ 272 -width 1 \ 273 -height 2 \ 274 -borderwidth 1 \ 275 -yscrollcommand [list .top.regexp.replace.result.sy set] \ 276 -xscrollcommand [list .top.regexp.replace.result.sx set] \ 277 ]; 278 scrollbar .top.regexp.replace.result.sy \ 279 -command ".top.regexp.replace.result.text yview" \ 280 -orient vertical \ 281 -borderwidth 1; 282 scrollbar .top.regexp.replace.result.sx \ 283 -command ".top.regexp.replace.result.text xview" \ 284 -orient horizontal \ 285 -borderwidth 1; 286 grid .top.regexp.replace.result.text .top.regexp.replace.result.sy -sticky news 287 grid .top.regexp.replace.result.sx x -sticky news 288 grid columnconfigure .top.regexp.replace.result 0 -weight 1; 289 grid rowconfigure .top.regexp.replace.result 0 -weight 1; 290 291 button .top.regexp.replace.replace \ 292 -text "Replace" \ 293 -underline 0 \ 294 -borderwidth 1 \ 295 -width 9 \ 296 -command [list regexp::replace]; 297 298 label .top.regexp.replace.numberOfReplacements \ 299 -textvariable regexp::data(v:nbreplace) \ 300 -width 12 \ 301 -anchor center \ 302 -relief sunken \ 303 -borderwidth 2; 304 305 set data(v:nbreplace) "? replaced"; 306 307 pack .top.regexp.replace.result -side left -fill both -expand true -pady 5 -padx 5 308 pack .top.regexp.replace.replace -side left -pady 5 309 pack .top.regexp.replace.numberOfReplacements -side right -fill x -pady 5 -padx 5 310 311 # layout 312 # 313 pack .top.regexp.pattern -side top -anchor w -padx 5 -pady {5 0} -expand 1 -fill both 314 pack .top.regexp.options -side top -anchor w -padx 5 -pady {0 5} -expand 0 -fill x 315 pack .top.regexp.buttons -side top -anchor w -padx 5 -expand 0 -fill x 316 317 update; 318 319 .top add .top.regexp -minsize [winfo reqheight .top.regexp] -sticky nesw; 320 321 # frame for sample 322 # 323 labelframe .top.sample -text "sample" -borderwidth 2 -relief groove; 324 frame .top.sample.sample; 325 # text for sample highlighting 326 # 327 set data(w:sample) [text .top.sample.sample.text \ 328 -background white \ 329 -undo 1 \ 330 -font $::font_sample \ 331 -borderwidth 1 \ 332 -width 80 \ 333 -height 10 \ 334 -selectbackground lightblue \ 335 -selectborderwidth 0 \ 336 -yscrollcommand [list .top.sample.sample.sy set] \ 337 -xscrollcommand [list .top.sample.sample.sx set] \ 338 ]; 339 scrollbar .top.sample.sample.sy \ 340 -command [list .top.sample.sample.text yview] \ 341 -orient vertical \ 342 -borderwidth 1; 343 scrollbar .top.sample.sample.sx \ 344 -command [list .top.sample.sample.text xview] \ 345 -orient horizontal \ 346 -borderwidth 1; 347 grid .top.sample.sample.text .top.sample.sample.sy -sticky news 348 grid .top.sample.sample.sx x -sticky news 349 grid columnconfigure .top.sample.sample 0 -weight 1; 350 grid rowconfigure .top.sample.sample 0 -weight 1; 351 352 # set tags for colors & special 353 # 354 set data(v:levels) {e0 e1 e2 e3 e4 e5 e6 e7 e8 e9}; 355 356 foreach level $data(v:levels) color $colors { 357 $data(w:regexp) tag configure $level -foreground $color; 358 $data(w:history) tag configure $level -foreground $color; 359 $data(w:sample) tag configure $level -foreground $color; 360 } 361 362 $data(w:regexp) tag configure lookahead -background $color_lookahead; 363 $data(w:regexp) tag configure noreport -background $color_noreport; 364 $data(w:history) tag configure lookahead -background $color_lookahead; 365 $data(w:history) tag configure noreport -background $color_noreport; 366 367 # options 368 # 369 frame .top.sample.matches; 370 # button for navigation 371 # 372 button .top.sample.matches.first \ 373 -text "First" \ 374 -borderwidth 1 \ 375 -pady 2 \ 376 -width 8 \ 377 -command [list regexp::sample:move -2]; 378 button .top.sample.matches.previous \ 379 -text "Previous" \ 380 -borderwidth 1 \ 381 -pady 2 \ 382 -width 8 \ 383 -command [list regexp::sample:move -1]; 384 button .top.sample.matches.next \ 385 -text "Next" \ 386 -borderwidth 1 \ 387 -pady 2 \ 388 -width 8 \ 389 -command [list regexp::sample:move +1]; 390 button .top.sample.matches.last \ 391 -text "Last" \ 392 -borderwidth 1 \ 393 -pady 2 \ 394 -width 8 \ 395 -command [list regexp::sample:move +2]; 396 397 set data(v:mainPositions) [list]; 398 set data(v:positions) [list]; 399 set data(v:mainPosition) 0; 400 set data(v:position) 0; 401 402 # check, if to move to sub matches too 403 # 404 checkbutton .top.sample.matches.subMatches \ 405 -text "goto sub matches" \ 406 -borderwidth 1 \ 407 -underline 6 \ 408 -variable regexp::data(v:subPositions) \ 409 -command [list regexp::sample:subPositions]; 410 411 set data(v:subPositions) 0; 412 413 # info for the count of matches and the current match 414 # 415 label .top.sample.matches.numberOfMatches \ 416 -textvariable regexp::data(v:nbmatches) \ 417 -anchor center \ 418 -relief sunken \ 419 -borderwidth 2; 420 421 set regexp::data(v:nbmatches) "0 / 0 matches"; 422 423 # layout 424 # 425 pack .top.sample.matches.first -side left -fill none -expand 0 -padx {0 5}; 426 pack \ 427 .top.sample.matches.previous \ 428 .top.sample.matches.next \ 429 .top.sample.matches.last \ 430 .top.sample.matches.subMatches \ 431 -side left -fill none -expand 0 -padx 5; 432 pack .top.sample.matches.numberOfMatches -side right -fill x -expand 1 -padx {5 0}; 433 434 # layout 435 # 436 pack .top.sample.sample -side top -fill both -expand 1 -padx 5 -pady 5; 437 pack .top.sample.matches -side bottom -fill x -expand 0 -padx 5 -pady 5; 438 439 update; 440 441 .top add .top.sample -minsize [winfo reqheight .top.sample] -sticky nesw; 442 443 update; 444 445 # main layout 446 # 447 pack .top -side top -fill both -expand 1 -padx 5 -pady 5; 448 449 update; 450 451 wm title . "Visual REGEXP $::version" 452 wm minsize . [winfo reqwidth .] [expr {[winfo reqheight .]+19}]; 453 wm geometry . [winfo reqwidth .]x[expr {[winfo reqheight .]+19}]; 454 455 wm deiconify .; 456 grab . 457 focus -force $data(w:regexp); 458 459 # main menu 460 . configure -menu .menubar 461 set m [menu .menubar -tearoff 0 -borderwidth 1 -activeborderwidth 1] 462 # file 463 $m add cascade -menu $m.file -label "File" -underline 0 464 set mm [menu $m.file -tearoff 0 -borderwidth 1 -activeborderwidth 1] 465 $mm add command -label "Load regexp ..." -command "regexp::regexp:load" 466 $mm add command -label "Load sample ..." -command "regexp::sample:load" -accelerator "Alt-O" 467 $mm add separator 468 $mm add command -label "Save sample (auto) ..." -command "regexp::sample:save auto" -accelerator "Alt-S" 469 $mm add command -label "Save sample Unix (lf) ..." -command "regexp::sample:save lf" 470 $mm add command -label "Save sample Windows (crlf) ..." -command "regexp::sample:save crlf" 471 $mm add command -label "Save sample Mac (cr) ..." -command "regexp::sample:save cr" 472 $mm add separator 473 $mm add command -label "Quit" -underline 0 -command "exit" -accelerator "Alt-Q" 474 # edit 475 $m add cascade -menu $m.edit -label "Edit" -underline 0 476 set mm [menu $m.edit -tearoff 0 -borderwidth 1 -activeborderwidth 1] 477 $mm add command -label "Copy regexp to clipboard" -command "regexp::dump clipboard" -accelerator "Alt-C" 478 # view 479 $m add cascade -menu $m.view -label "View" -underline 0 480 set mm [menu $m.view -tearoff 0 -borderwidth 1 -activeborderwidth 1] 481 set regexp::data(v:background) $::background 482 regexp::sample:background 483 $mm add checkbutton -label "Show background for matches" -command "regexp::sample:background" \ 484 -variable regexp::data(v:background) 485 $mm add checkbutton -label "Show regexp help" -command "regexp::regexp:help:toggle" \ 486 -variable regexp::data(v:help) 487 set regexp::data(v:help) $show_help 488 $mm add checkbutton -label "Wrap lines in sample" -variable regexp::data(v:wrap) \ 489 -command "$data(w:sample) configure -wrap \$regexp::data(v:wrap)" \ 490 -offvalue "none" -onvalue "char" 491 set regexp::data(v:history) $history 492 $mm add checkbutton -label "History of Regexp" -variable regexp::data(v:history) \ 493 -command "if {\$regexp::data(v:history)} {wm deiconify .history} else {wm iconify .history}" 494 # select mode 495 $m add cascade -menu $m.select -label "Select/Replace mode" -underline 5 496 set mm [menu $m.select -tearoff 0 -borderwidth 1 -activeborderwidth 1] 497 $mm add radiobutton -label "select / concat raw matches" \ 498 -variable regexp::data(v:mode) -value "raw" -command regexp::replace:toggle 499 $mm add radiobutton -label "select / insert new line between matches" \ 500 -variable regexp::data(v:mode) -value "nl" -command regexp::replace:toggle 501 $mm add radiobutton -label "replace matches" \ 502 -variable regexp::data(v:mode) -value "replace" -command regexp::replace:toggle 503 # insert well know regexp 504 $m add cascade -menu $m.insert -label "Insert regexp" -underline 11 505 set mm [menu $m.insert -tearoff 0 -borderwidth 1 -activeborderwidth 1] 506 $mm add command -label "Make regexp ..." -command "regexp::make-regexp" 507 $mm add separator 508 $mm add command -label "Load patterns ..." -command "regexp::pattern:load" 509 $mm add separator 510 foreach {n e} $regexp_db { 511 $mm add command -label "$n" -command "regexp::regexp:insert [list $e]" 512 } 513 set data(w:menu) $mm 514 # help 515 $m add cascade -menu $m.help -label "Help" -underline 0 516 set mm [menu $m.help -tearoff 0 -borderwidth 1 -activeborderwidth 1] 517 $mm add checkbutton -label "dump regexp to console" -underline 0 -variable regexp::data(v:dumpToConsole); 518 $mm add checkbutton -label "dump regexp to clipboard" -underline 0 -variable regexp::data(v:dumpToClipboard); 519 $mm add separator 520 $mm add command -label "tcl console" -underline 0 -command "console show"; 521 $mm add separator 522 $mm add command -label "Help" -underline 0 -command "regexp::help" 523 524 525 # key binding 526 bind all <Alt-q> "exit" 527 bind all <Alt-g> "regexp::go" 528 bind $data(w:regexp) <Return> "regexp::go; break" 529 bind all <Alt-c> "regexp::dump clipboard" 530 bind all <Alt-r> "regexp::replace" 531 bind all <Alt-o> "regexp::sample:load" 532 bind all <Alt-s> "regexp::sample:save auto" 533 534 bind all <Alt-a> [list .top.regexp.options.all toggle]; 535 bind all <Alt-n> [list .top.regexp.options.nocase toggle]; 536 bind all <Alt-l> [list .top.regexp.options.line toggle]; 537 bind all <Alt-k> [list .top.regexp.options.lineanchor toggle]; 538 bind all <Alt-m> [list .top.regexp.options.linestop toggle]; 539 bind all <Alt-i> [list .top.regexp.options.inline toggle]; 540 bind all <Alt-u> [list .top.sample.matches.subMatches toggle]; 541 bind all <Alt-z> [list regexp::clear]; 542 543 544 bind $data(w:sample) <Control-Tab> "$data(w:sample) insert insert {\t}; break;" 545 546 # special for regexp Ctrl+letter = \<letter> 547 # 548 bind $data(w:regexp) <Control-V> "event generate $data(w:regexp) <Shift-Insert>;" 549 bind $data(w:regexp) <Control-C> "event generate $data(w:regexp) <Control-Insert>;" 550 bind $data(w:regexp) <Control-X> "event generate $data(w:regexp) <Shift-Delete>;" 551 552 bind $data(w:regexp) <Control-Tab> "$data(w:regexp) insert insert {\t}; break;" 553 bind $data(w:regexp) <Control-Return> "$data(w:regexp) insert insert {\n}; break;" 554 555 foreach key {a b B e f n r t v u x 0 d D s S w W A Z m M y Y} { 556 bind $data(w:regexp) <Control-$key> "$data(w:regexp) insert insert {\\$key}; break;" 557 } 558 foreach key {a b B e f n r t v u x 0} { 559 bind $data(w:replace) <Control-$key> "$data(w:replace) insert insert {\\$key}; break;" 560 } 561 562 bind Text <Control-v> {} 563 564 # font selection popup 565 foreach w {regexp replace sample} { 566 set m [menu .fonts_$w -tearoff 0] 567 foreach f $::fonts { 568 if { $f == "----"} { 569 $m add separator 570 } else { 571 $m add command -label $f -command [list $data(w:$w) configure -font [list $f]]; 572 } 573 } 574 bind $data(w:$w) <3> "tk_popup $m %X %Y" 575 } 576 577 # some init 578 # martin lemburg @ gmx.net - 2006-03-02 579 # 580 foreach {option flag} {nocase 1 all 1 line 1 lineanchor 0 linestop 0 inline 0} { 581 if {$flag == 1} { 582 set value -$option; 583 } else { 584 set value ""; 585 } 586 587 set data(v:$option) $value; 588 } 589 # 590 # martin lemburg @ gmx.net - 2006-03-02 591 592 set data(v:wrap) "char" 593 set regexp::data(v:mode) $::mode 594 replace:toggle ;# set bindings 595 regexp:help:toggle 596} 597 598proc regexp::pattern:load {{file ""}} { 599variable data 600 601 # get filename 602 if {$file == ""} { 603 set types [list [list "All" *]] 604 set file [tk_getOpenFile -filetypes $types -parent .] 605 if {$file == ""} { 606 return 607 } 608 } 609 # do it 610 set in [open $file "r"] 611 $data(w:menu) delete [expr 4+[llength $::regexp_db]/2] end 612 while {![eof $in]} { 613 set name [gets $in] 614 while {$name == ""} { 615 set name [gets $in] 616 } 617 set pattern [gets $in] 618 while {$pattern == ""} { 619 set pattern [gets $in] 620 } 621 $data(w:menu) add command -label $name -command "regexp::regexp:insert [list $pattern]" 622 } 623 close $in 624} 625 626 627#---------------------------------------------------------------------------------------------- 628# Main toplevel commands 629#---------------------------------------------------------------------------------------------- 630 631proc regexp::go {} { 632variable data 633 634 set exp [$data(w:regexp) get 1.0 end-1char] 635 # check if regexp is OK 636 if {[catch { regexp -- $exp dummy } errMsg]} { 637 tk_messageBox -type ok -icon error -message "Malformed regexp: $errMsg" 638 return 639 } 640 regexp::regexp:colorize 641 regexp::sample:colorize 642 regexp::history:add 643} 644 645proc regexp::clear {} { 646variable data 647 648 regexp::history:add 649 $data(w:regexp) delete 1.0 end 650 regexp::go 651} 652 653proc regexp::dump {{destinations {}}} { 654variable data 655 656 # update display 657 go 658 # built list of options 659 set dump "regexp" 660 foreach option {nocase all line lineanchor linestop inline} { 661 if {$data(v:$option) != ""} { 662 append dump " $data(v:$option)" 663 } 664 } 665 # build expression 666 set exp [$data(w:regexp) get 1.0 end-1char] 667 append dump " -- {$exp} string" 668 # add variables if needed 669 if {$data(v:inline) == ""} { 670 append dump " match" 671 for {set i 1} {$i < $data(v:nblevels)} {incr i} { 672 append dump " v$i" 673 } 674 } 675 676 # put the dump explicitely into the clipboard 677 # 678 if {([lsearch -exact $destinations clipboard] != -1) || 679 (([llength $destinations] == 0) && 680 ($data(v:dumpToClipboard) == 1))} { 681 clipboard clear; 682 clipboard append $dump; 683 } 684 685 if {([lsearch -exact $destinations console] != -1) || 686 (([llength $destinations] == 0) && 687 ($data(v:dumpToConsole) == 1))} { 688 puts "$dump"; 689 } 690} 691 692proc regexp::select {level} { 693variable data 694 695 # update 696 go 697 if {[llength $data(v:result)] == 0} { 698 bell 699 return 700 } 701 702 # puts regexp 703 704 if {($data(v:dumpToConsole) == 1) || 705 ($data(v:dumpToClipboard) == 1)} { 706 dump; 707 } 708 709 # extract matching parts in sample 710 set i 0 711 set newsample "" 712 foreach match $data(v:result) { 713 if {($i % $data(v:nblevels)) == $level} { 714 set text [$data(w:sample) get \ 715 [$data(w:sample) index "1.0+[lindex $match 0]chars"] \ 716 [$data(w:sample) index "1.0+[expr [lindex $match 1]+1]chars"]] 717 append newsample $text 718 if {$data(v:mode) == "nl"} { 719 append newsample "\n" 720 } 721 } 722 incr i 723 } 724 $data(w:sample) delete 1.0 end 725 $data(w:sample) insert 1.0 $newsample 726 # update with regexp 727 go 728} 729 730proc regexp::help {} { 731global tcl_platform 732 733 toplevel .help 734 wm title .help "Help" 735 # logo 736 label .help.l -image logo 737 pack .help.l -side top -padx 10 -pady 10 738 # help text 739 # 740 frame .help.text; 741 742 if {$tcl_platform(platform) == "windows"} { 743 text .help.text.t -borderwidth 2 -relief groove -font {Courier 10} -yscrollcommand [list .help.text.sy set]; 744 } else { 745 text .help.text.t -borderwidth 2 -relief groove -yscrollcommand [list .help.text.sy set]; 746 } 747 748 scrollbar .help.text.sy \ 749 -command ".help.text.t yview" \ 750 -orient vertical \ 751 -borderwidth 1; 752 753 pack .help.text.t -side left -fill both -expand 1; 754 pack .help.text.sy -side left -fill y -expand 0; 755 756 pack .help.text -side top -fill both -expand 1 -padx 20 757 758 .help.text.t tag configure bold -font "[.help.text.t cget -font] bold" 759 .help.text.t insert 1.0 "Version:" bold " $::version 760 761" normal "Usage:" bold " tkregexp <sampleFile> 762 763" normal "Key bindings:" bold " Alt-q exit 764 Alt-a toggle 'all' flag 765 Alt-n toggle 'nocase' flag 766 Alt-l toggle 'line' flag 767 Alt-k toggle 'lineanchor' flag 768 Alt-m toggle 'linestop' flag 769 Alt-i toggle 'inline' flag 770 Alt-g do the highlighting 771 Return (in regexp) do the highlighting 772 773" normal "To clipboard:" bold " Put the 'regexp' command with its arguments to the clipboard 774 775" normal "Tips:" bold " 1) To set the sample, either put a filename on the command line, 776 or just copy & paste it in the sample text window. 777 2) You can change the default colors or windows size by editing the 778 first lines of the program file. 779 3) When using the replace function, using Control-Z restore the value 780 of the sample before the replacement : you try, retry, reretry, ... 781 782" normal "Send your bug reports, suggestions or any feedback to:" bold " 783 784 mailto:laurent.riesterer@free.fr 785 http://laurent.riesterer.free.fr/regexp 786" normal 787 .help.text.t configure -state disabled; 788 789 # ok button 790 button .help.ok -text "Ok" -width 10 -default active -command "destroy .help" 791 pack .help.ok -side bottom -pady 10 792} 793 794proc regexp::regexp:help:toggle {} { 795variable data 796 797 if {$data(v:help) == 0} { 798 pack forget $data(w:help) 799 } else { 800 pack $data(w:help) -before [winfo parent $data(w:regexp)] -fill x -padx 5 801 802 update; 803 804 .top paneconfigure .top.regexp -minsize [winfo reqheight .top.regexp]; 805 806 update; 807 } 808} 809 810#---------------------------------------------------------------------------------------------- 811# Undo/redo (quick and dirty UNDO/REDO support) 812#---------------------------------------------------------------------------------------------- 813 814proc regexp::undo:sample {} { 815variable data 816 817 # display result 818 $data(w:sample) delete 1.0 end 819 $data(w:sample) insert 1.0 $data(v:undo:sample) 820 # colorize 821 go 822} 823 824proc regexp::unredo:regexp {dir} { 825variable data 826 827 set index [expr ($data(v:undo:index)+$dir) % 100] 828 if {![info exists data(v:undo:r$index)]} { 829 return 830 } 831 set data(v:undo:index) $index 832 833 set t $data(w:regexp) 834 $t delete 1.0 end 835 $t insert 1.0 [lindex $data(v:undo:r$index) 1] 836 $t mark set insert [lindex $data(v:undo:r$index) 0] 837} 838 839proc regexp::undo:regexp:compute {w k a} { 840variable data 841 842 if {[string match -nocase "*control*" $k] 843 || [string match -nocase "*shift*" $k] 844 || [string match -nocase "*alt*" $k]} { 845 return 846 } 847 848 set data(v:undo:r$data(v:undo:index)) [list [$w index insert] [$w get 1.0 end-1char]] 849 set data(v:undo:index) [expr ($data(v:undo:index)+1) % 100] 850} 851 852#---------------------------------------------------------------------------------------------- 853# Replace 854#---------------------------------------------------------------------------------------------- 855 856proc regexp::replace {} { 857variable data 858 859 set exp [$data(w:regexp) get 1.0 end-1char] 860 set subst [$data(w:replace) get 1.0 end-1char] 861 if {$exp == ""} { 862 set regexp::data(v:nbreplace) "empty regexp" 863 return 864 } 865 866 # get sample & store it for undo 867 set sample [$data(w:sample) get 1.0 end] 868 set data(v:undo:sample) $sample 869 set result [eval regsub $data(v:all) \ 870 $data(v:line) $data(v:lineanchor) $data(v:linestop) \ 871 $data(v:nocase) -- \ 872 [list $exp] [list $sample] [list [subst -nocommands -novariables $subst]] sample] 873 set regexp::data(v:nbreplace) "$result replaced" 874 # display result 875 $data(w:sample) delete 1.0 end 876 $data(w:sample) insert 1.0 $sample 877} 878 879proc regexp::replace:toggle {} { 880variable data 881 882 if {$regexp::data(v:mode) == "replace"} { 883 bind $data(w:regexp) <Tab> "focus $data(w:replace); break;" 884 bind $data(w:regexp) <Shift-Tab> "focus $data(w:sample); break;" 885 catch { bind $data(w:regexp) <ISO_Left_Tab> "focus $data(w:sample); break;" } 886 887 bind $data(w:replace) <Tab> "focus $data(w:sample); break;" 888 bind $data(w:replace) <Shift-Tab> "focus $data(w:regexp); break;" 889 catch { bind $data(w:replace) <ISO_Left_Tab> "focus $data(w:regexp); break;" } 890 891 bind $data(w:sample) <Tab> "focus $data(w:regexp); break;" 892 bind $data(w:sample) <Shift-Tab> "focus $data(w:replace); break;" 893 catch { bind $data(w:sample) <ISO_Left_Tab> "focus $data(w:replace); break;" } 894 895 pack $data(w:allreplace) -side top -fill both; 896 } else { 897 bind $data(w:regexp) <Tab> "focus $data(w:sample); break;" 898 catch { bind $data(w:regexp) <ISO_Left_Tab> "focus $data(w:sample); break;" } 899 900 bind $data(w:sample) <Tab> "focus $data(w:regexp); break;" 901 catch { bind $data(w:sample) <ISO_Left_Tab> "focus $data(w:regexp); break;" } 902 903 pack forget $data(w:allreplace) 904 } 905 906 update; 907 908 .top paneconfigure .top.regexp -minsize [winfo reqheight .top.regexp]; 909 910 update; 911} 912 913#---------------------------------------------------------------------------------------------- 914# Manage REGEXP 915#---------------------------------------------------------------------------------------------- 916 917proc regexp::regexp:set {text} { 918variable data 919 920 $data(w:regexp) delete 1.0 end 921 $data(w:regexp) insert 1.0 $text 922} 923 924proc regexp::regexp:colorize {} { 925variable data 926 927 set exp [$data(w:regexp) get 1.0 end-1char] 928 set max [string length $exp] 929 set stack {} 930 # list format : min max min max ... 931 set indices [list "report" 0 [string length $exp]] 932 # search the groups in the regexp 933 set data(v:nblevels) 1 934 for {set i 0} {$i < $max} {incr i} { 935 set c [string index $exp $i] 936 if {$c == "\\"} { 937 incr i 938 continue 939 } elseif {$c == "("} { 940 set c [string index $exp [expr $i+1]] 941 set what [string index $exp [expr $i+2]] 942 # test for escape with (?...) 943 if {$c == "?"} { 944 if {$what != ":"} { 945 lappend indices "lookahead" 946 } else { 947 lappend indices "noreport" 948 } 949 } else { 950 lappend indices "report" 951 incr data(v:nblevels) 952 } 953 lappend indices $i 954 set stack "[llength $indices] $stack" 955 lappend indices 0 956 957 } elseif {$c == ")"} { 958 set idx [lindex $stack 0] 959 if {$idx == ""} { 960 continue 961 } 962 set stack [lrange $stack 1 end] 963 set indices [lreplace $indices $idx $idx $i] 964 } 965 } 966 967 # remove old colors 968 foreach level $data(v:levels) { 969 $data(w:regexp) tag remove $level 1.0 end 970 } 971 $data(w:regexp) tag remove "lookahead" 1.0 end 972 $data(w:regexp) tag remove "noreport" 1.0 end 973 # colorize the regexp 974 set i 0 975 foreach {type min max} $indices { 976 if {$type != "report"} { 977 continue 978 } 979 $data(w:regexp) tag add [lindex $data(v:levels) $i] \ 980 [$data(w:regexp) index "1.0+${min}chars"] \ 981 [$data(w:regexp) index "1.0+[expr $max+1]chars"] 982 incr i 983 } 984 # apply special item 985 foreach {type min max} $indices { 986 if {$type == "report"} { 987 continue 988 } 989 $data(w:regexp) tag add $type \ 990 [$data(w:regexp) index "1.0+${min}chars"] \ 991 [$data(w:regexp) index "1.0+[expr $max+1]chars"] 992 } 993} 994 995#---------------------------------------------------------------------------------------------- 996 997proc regexp::regexp:load {} { 998variable data 999 1000 # get filename 1001 set types [list [list "All" *]] 1002 set file [tk_getOpenFile -filetypes $types -parent .] 1003 if {$file == ""} { 1004 return 1005 } 1006 # do it 1007 set in [open $file "r"] 1008 regexp:set [read $in [file size $file]] 1009 close $in 1010} 1011 1012#---------------------------------------------------------------------------------------------- 1013 1014proc regexp::regexp:insert {what} { 1015variable data 1016 1017 set w $data(w:regexp) 1018 # prepare undo/redo 1019 set data(v:undo:r$data(v:undo:index)) [list [$w index insert] [$w get 1.0 end-1char]] 1020 set data(v:undo:index) [expr ($data(v:undo:index)+1) % 100] 1021 # do it 1022 $w insert insert $what 1023 # prepare undo/redo 1024 set data(v:undo:r$data(v:undo:index)) [list [$w index insert] [$w get 1.0 end-1char]] 1025} 1026 1027#---------------------------------------------------------------------------------------------- 1028# History window to memorize already typed regexp 1029 1030proc regexp::history:init {} { 1031variable data 1032global font 1033 1034 set w [toplevel .history] 1035 wm title $w "Visual REGEXP $::version -- REGEXP History" 1036 wm geometry $w 640x480 1037 wm protocol $w WM_DELETE_WINDOW "set regexp::data(v:history) 0; wm withdraw $w" 1038 1039 # text zone 1040 set tf [frame $w.t] 1041 pack $tf -side top -expand true -fill both 1042 set t [text $tf.t -xscrollcommand "$tf.x set" -yscrollcommand "$tf.y set" \ 1043 -background white -font $::font_regexp -width 5 -height 1 \ 1044 -selectbackground lightblue -selectborderwidth 0] 1045 set data(w:history) $t 1046 $t tag configure spacing -font {Helvetica 6} 1047 set tx [scrollbar $tf.x -borderwidth 1 -orient horizontal -command "$t xview"] 1048 set ty [scrollbar $tf.y -borderwidth 1 -orient vertical -command "$t yview"] 1049 bindtags $t "$t all" 1050 grid $t $ty -sticky news 1051 grid $tx x -sticky news 1052 grid columnconfigure $tf {0} -weight 1 1053 grid columnconfigure $tf {1} -weight 0 1054 grid rowconfigure $tf {0} -weight 1 1055 grid rowconfigure $tf {1} -weight 0 1056 1057 # buttons 1058 set bf [frame $w.f] 1059 pack $bf -side bottom -padx 5 -pady 5 1060 1061 set b1 [button $bf.1 -borderwidth 1 -text "Hide" -command "wm withdraw $w; set ::regexp::data(v:history) 0"] 1062 set b2 [button $bf.2 -borderwidth 1 -text "Save ..." -command "regexp::history:save"] 1063 pack $b2 $b1 -side left -anchor c 1064 1065 wm withdraw $w 1066} 1067 1068set last "" 1069set counter 0 1070 1071proc regexp::history:add {} { 1072variable data 1073 1074 if {$::inReplay} { 1075 # avoid to put the same expression again when replaying it 1076 set ::inReplay 0 1077 return 1078 } 1079 1080 set exp [$data(w:regexp) get 1.0 end-1char] 1081 if {$exp != "" && $exp != $::last} { 1082 # memorize position 1083 set start [$data(w:history) index insert] 1084 # add text 1085 $data(w:history) insert end "$exp\n" 1086 set end [$data(w:history) index insert] 1087 $data(w:history) insert end "\n" {spacing} 1088 set ::last $exp 1089 $data(w:history) yview moveto 1.0 1090 # do the binding 1091 set tag "t$::counter" 1092 incr ::counter 1093 $data(w:history) tag bind $tag <Any-Enter> "$data(w:history) tag configure $tag -background lightblue" 1094 $data(w:history) tag bind $tag <Any-Leave> "$data(w:history) tag configure $tag -background {}" 1095 $data(w:history) tag bind $tag <1> "regexp::history:replay [list $exp]" 1096 $data(w:history) tag add $tag $start $end 1097 1098 # colorize the expression in history 1099 scan $start "%d.%d" sl sc 1100 incr sl -1 1101 foreach tag {e0 e1 e2 e3 e4 e5 e6 e7 e8 e9 lookahead noreport} { 1102 foreach {start end} [$data(w:regexp) tag ranges $tag] { 1103 set start [$data(w:history) index "$start + $sc chars + $sl lines"] 1104 set end [$data(w:history) index "$end + $sc chars + $sl lines"] 1105 $data(w:history) tag add $tag $start $end 1106 } 1107 } 1108 } 1109} 1110 1111set inReplay 0 1112 1113proc regexp::history:replay {text} { 1114variable data 1115 1116 set ::inReplay 1 1117 regexp:set $text 1118 go 1119} 1120 1121proc regexp::history:save {} { 1122variable data 1123 1124 set file [tk_getSaveFile -defaultextension .txt] 1125 if {$file != ""} { 1126 set out [open $file "w"] 1127 puts -nonewline $out [$data(w:history) get 1.0 end] 1128 close $out 1129 } 1130} 1131 1132 1133#---------------------------------------------------------------------------------------------- 1134# Manage SAMPLE 1135#---------------------------------------------------------------------------------------------- 1136 1137proc regexp::sample:set {text} { 1138variable data 1139 1140 $data(w:sample) delete 1.0 end 1141 $data(w:sample) insert 1.0 $text 1142 set data(v:undo:sample) $text 1143} 1144 1145proc regexp::sample:colorize {} { 1146variable data 1147 1148 # remove old tags 1149 foreach level $data(v:levels) { 1150 $data(w:sample) tag remove $level 1.0 end 1151 } 1152 set data(v:position) 0; 1153 set data(v:mainPosition) 0; 1154 set data(v:positions) [list]; 1155 set data(v:mainPositions) [list]; 1156 1157 array unset data v:mainPositions.*; 1158 1159 # set new tags 1160 # 1161 set exp [$data(w:regexp) get 1.0 end-1char]; 1162 1163 if {$exp == ""} { 1164 set data(v:result) {} 1165 return 1166 } 1167 1168 set result [eval \ 1169 regexp -inline -indices \ 1170 $data(v:all) \ 1171 $data(v:line) $data(v:lineanchor) $data(v:linestop) \ 1172 $data(v:nocase) \ 1173 -- \ 1174 [list $exp] [list [$data(w:sample) get 1.0 end]] \ 1175 ]; 1176 1177 set data(v:result) $result 1178 1179 set i 0; 1180 set matchFirst -1; 1181 set matchLast -1; 1182 set mainMatchesCount 0; 1183 set allMatchesCount 0; 1184 1185 foreach match $result { 1186 foreach {first last} $match {break;}; 1187 1188 if {($matchFirst == -1) || ($first > $matchLast)} { 1189 set matchFirst $first; 1190 set matchLast $last; 1191 set newMatch 1; 1192 1193 incr mainMatchesCount; 1194 } else { 1195 set newMatch 0; 1196 } 1197 1198 if {$first != -1} { 1199 set start [$data(w:sample) index "1.0+[lindex $match 0]chars"]; 1200 1201 $data(w:sample) tag add \ 1202 e[expr $i % $data(v:nblevels)] \ 1203 $start [$data(w:sample) index "1.0+[expr [lindex $match 1]+1]chars"]; 1204 1205 1206 if {$newMatch == 1} { 1207 set mainStart $start; 1208 1209 lappend data(v:mainPositions) $start; 1210 } else { 1211 lappend data(v:mainPositions.$mainStart) $start 1212 } 1213 1214 lappend data(v:positions) $start; 1215 1216 if {$i == 0} { 1217 $data(w:sample) see $start 1218 } 1219 1220 incr i; 1221 incr allMatchesCount; 1222 } 1223 } 1224 1225 set data(v:mainMatchesCount) $mainMatchesCount; 1226 set data(v:allMatchesCount) $allMatchesCount; 1227 1228 # set nb of matches 1229 # 1230 if {$data(v:nblevels)} { 1231 set nb 0 1232 foreach item $result { 1233 if {[lindex $item 0] <= [lindex $item 1]} { 1234 incr nb 1235 } 1236 } 1237 1238 if {$data(v:subPositions) == 0} { 1239 set count $mainMatchesCount; 1240 } else { 1241 set count $allMatchesCount; 1242 } 1243 1244 set data(v:nbmatches) "0 / $count matches" 1245 } else { 1246 set data(v:nbmatches) "? / ? matches" 1247 } 1248 1249 sample:move -2; 1250} 1251 1252proc regexp::sample:background {} { 1253variable data 1254 1255 foreach level $data(v:levels) color $::colors bgcolor $::bgcolors { 1256 if {$data(v:background)} { 1257 $data(w:sample) tag configure $level -foreground $color -background $bgcolor 1258 } else { 1259 $data(w:sample) tag configure $level -foreground $color -background {} 1260 } 1261 } 1262} 1263 1264proc regexp::sample:subPositions {} { 1265 variable data; 1266 1267 set position $data(v:position); 1268 set mainPosition $data(v:mainPosition); 1269 1270 sample:colorize; 1271 1272 set data(v:position) $position; 1273 set data(v:mainPosition) $mainPosition; 1274 1275 if {$data(v:subPositions) == 1} { 1276 set data(v:position) [lsearch -exact \ 1277 $data(v:positions) \ 1278 [lindex $data(v:mainPositions) $data(v:mainPosition)] \ 1279 ]; 1280 } else { 1281 set idx 0; 1282 1283 foreach position $data(v:mainPositions) { 1284 if {[lsearch -exact $data(v:mainPositions.$position) [lindex $data(v:positions) $data(v:position)]] != -1} { 1285 set data(v:mainPosition) $idx; 1286 break; 1287 } 1288 1289 incr idx; 1290 } 1291 } 1292 1293 sample:move 0; 1294} 1295 1296proc regexp::sample:move {amount} { 1297variable data 1298 1299 if {[llength $data(v:positions)] == 0} { 1300 set data(v:nbmatches) "0 / 0 matches" 1301 return; 1302 } 1303 1304 if {$amount == -2} { 1305 if {$data(v:subPositions) == 1} { 1306 set data(v:position) 0; 1307 } else { 1308 set data(v:mainPosition) 0; 1309 } 1310 } elseif {$amount == +2} { 1311 if {$data(v:subPositions) == 1} { 1312 set data(v:position) [expr {[llength $data(v:positions)]-1}]; 1313 } else { 1314 set data(v:mainPosition) [expr {[llength $data(v:mainPositions)]-1}]; 1315 } 1316 } elseif {$amount == -1} { 1317 if {$data(v:subPositions) == 1} { 1318 if {$data(v:position) > 0} { 1319 incr data(v:position) -1 1320 } 1321 } else { 1322 if {$data(v:mainPosition) > 0} { 1323 incr data(v:mainPosition) -1 1324 } 1325 } 1326 } elseif {$amount == +1} { 1327 if {$data(v:subPositions) == 1} { 1328 if {$data(v:position) < [llength $data(v:positions)]-1} { 1329 incr data(v:position) +1 1330 } 1331 } else { 1332 if {$data(v:mainPosition) < [llength $data(v:mainPositions)]-1} { 1333 incr data(v:mainPosition) +1 1334 } 1335 } 1336 } 1337 1338 if {$data(v:subPositions) == 1} { 1339 set where [lindex $data(v:positions) $data(v:position)]; 1340 } else { 1341 set where [lindex $data(v:mainPositions) $data(v:mainPosition)]; 1342 } 1343 1344 if {$where != ""} { 1345 if {$data(v:subPositions) == 1} { 1346 set number $data(v:position); 1347 set count $data(v:allMatchesCount); 1348 } else { 1349 set number $data(v:mainPosition); 1350 set count $data(v:mainMatchesCount); 1351 } 1352 1353 set data(v:nbmatches) "[expr {$number + 1}] / $count matches" 1354 1355 $data(w:sample) see $where 1356 $data(w:sample) mark set insert $where 1357 1358 focus $data(w:sample) 1359 } 1360} 1361 1362#---------------------------------------------------------------------------------------------- 1363 1364proc regexp::sample:load {} { 1365variable data 1366 1367 # get filename 1368 set types [list [list "All" *]] 1369 set file [tk_getOpenFile -initialdir $data(v:dir) -filetypes $types -parent .] 1370 if {$file == ""} { 1371 return 1372 } 1373 # memorize location 1374 set data(v:dir) [file dirname $file] 1375 set data(v:file) [file tail $file] 1376 # do it 1377 set in [open $file "r"] 1378 sample:set [read $in [file size $file]] 1379 close $in 1380} 1381 1382proc regexp::sample:save {mode} { 1383variable data 1384 1385 # get filename 1386 set types [list [list "All" *]] 1387 set file [tk_getSaveFile -initialdir $data(v:dir) -initialfile $data(v:file) \ 1388 -filetypes $types -parent .] 1389 if {$file == ""} { 1390 return 1391 } 1392 # memorize location 1393 set data(v:dir) [file dirname $file] 1394 set data(v:file) [file tail $file] 1395 # do it 1396 set out [open $file "w"] 1397 fconfigure $out -translation $mode 1398 puts $out [$data(w:sample) get 1.0 end] 1399 close $out 1400} 1401 1402 1403#---------------------------------------------------------------------------------------------- 1404# Main toplevel commands 1405#---------------------------------------------------------------------------------------------- 1406 1407proc regexp::make-regexp {} { 1408variable data 1409 1410 # new dialog 1411 catch { destroy .mkregexp } 1412 set w [toplevel .mkregexp] 1413 wm title $w "Make regexp" 1414 wm geometry $w 640x480 1415 # widgets 1416 set f [frame $w.top] 1417 # area to input words 1418 label $f.l1 -text "Words list:" 1419 set list [text $f.list \ 1420 -wrap char \ 1421 -background white \ 1422 -font $::font_regexp \ 1423 -undo 1 \ 1424 -selectbackground lightblue \ 1425 -selectborderwidth 0 \ 1426 -width 1 \ 1427 -height 10 \ 1428 -borderwidth 1 \ 1429 -yscrollcommand [list $f.sy1 set] \ 1430 ]; 1431 scrollbar $f.sy1 -command "$list yview" -orient vertical -bd 1 1432 # button to compute the regexp 1433 set doit [button $f.doit -text "Compute" -width 15 -bd 1 -command "regexp::make-regexp:compute"] 1434 # display result 1435 label $f.l2 -text "Regexp:" 1436 set output [text $f.output \ 1437 -wrap char \ 1438 -undo 1 \ 1439 -background white 1440 -font $::font_regexp \ 1441 -selectbackground lightblue \ 1442 -selectborderwidth 0 \ 1443 -width 1 \ 1444 -height 4 \ 1445 -borderwidth 1 \ 1446 -yscrollcommand [list $f.sy2 set] \ 1447 ]; 1448 bindtags $output "$output all" 1449 scrollbar $f.sy2 -command "$output yview" -orient vertical -bd 1 1450 # layout 1451 grid $f.l1 $list $f.sy1 -sticky news 1452 grid $doit - - -sticky ns -pady 2 1453 grid $f.l2 $output $f.sy2 -sticky news 1454 grid columnconfigure $f {1} -weight 1 1455 grid rowconfigure $f {0 2} -weight 1 1456 # init 1457 set data(w:make:list) $list 1458 set data(w:make:output) $output 1459 # button OK / CANCEL 1460 set ff [frame $w.bottom] 1461 set ok [button $ff.ok -text "Insert into regexp" -width 20 -bd 1 -command "regexp::make-regexp:ok $w"] 1462 set cancel [button $ff.cancel -text "Cancel" -width 20 -bd 1 -command "destroy $w"] 1463 pack $ok $cancel -side left -fill both -padx 10 -pady 10 1464 # layout 1465 pack $f -side top -expand true -fill both 1466 pack $ff -side bottom -anchor c 1467} 1468 1469proc regexp::make-regexp:compute {} { 1470variable data 1471 1472 set words [$data(w:make:list) get 1.0 end-1c] 1473 $data(w:make:output) delete 1.0 end 1474 $data(w:make:output) insert 1.0 [make-regexp::make-regexp $words] 1475} 1476 1477proc regexp::make-regexp:ok {w} { 1478variable data 1479 1480 set words [$data(w:make:list) get 1.0 end-1c] 1481 1482 $data(w:regexp) insert insert "([make-regexp::make-regexp $words])" 1483 destroy $w 1484} 1485 1486 1487#============================================================================================== 1488# Main entry point 1489#============================================================================================== 1490 1491# try to get customization from 'visual_regexp.ini' 1492puts "[file exists visual_regexp.ini]" 1493set filename [file dirname [info nameofexecutable]]/visual_regexp.ini 1494if {[file exists $filename]} { 1495 source $filename 1496} elseif {[file exists visual_regexp.ini]} { 1497 source visual_regexp.ini 1498} 1499 1500# try to auto user patterns 1501set filename [file dirname [info nameofexecutable]]/regexp.txt 1502if {[file exists $filename]} { 1503 regexp::pattern:load $filename 1504} elseif {[file exists regexp.txt]} { 1505 regexp::pattern:load regexp.txt 1506} 1507 1508# buld the GUI 1509regexp::history:init 1510regexp::gui 1511regexp::go 1512 1513if {$argc > 1} { 1514 puts "Usage: $argv0 <sampleFile>" 1515} elseif {$argc == 1} { 1516 set filename [lindex $argv 0] 1517 set file [open $filename] 1518 set data [read $file [file size $filename]] 1519 close $file 1520 1521 # memorize location 1522 set regexp::data(v:dir) [file dirname $filename] 1523 set regexp::data(v:file) [file tail $filename] 1524 1525 regexp::sample:set $data 1526 unset data 1527} 1528 1529 1530#---------------------------------------------------------------------------------------------- 1531 1532image create photo logo -data {R0lGODlhLAFxAMYAAAICAhcXFzw8WFtbb4+Njq2ssioqNMfGxkJCSgYCtcYtJrjOuEpGVs3Y0FJOYr1JNb53Yt/g4BsXq+i9yspGHOjQ08adlebm5rm57unH0NwjGPY4EsJaIgYCwqOjp2hmet6+wurq6uTYvvcuE77Ovh4altZLE9C0uioqjrljT76OevtCDt7Hx7q5u8LC7tzZ2PsbFnJyhvsqEspWGvxaCgYC0+jh3cLSwh4akujY2Ll8Z5qZm8rK6tDQ6PxODNHQ0f///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////yH5BAEKAEAALAAAAAAsAXAAAAf+gBEvBy2FBz8XiYqLixGEhT8vjJOUjD+PLZGVm5yCl4WghpEREZymlBE/hqWnio8HrbGngoUvrLKEP7eym4+SnS0HpaqEB8bHFyHKF57GycrQ0RcNhAWQsSEvl6O8lJ+Qv92TIY6hoIcvts/im9mfwrLlBYjs4uTF4uXq9YwRwfSbUmUKwYxUMVu7Uh2DF60hwXKgAJoiV5DfIlWgGoSzmA2UtQMaSVk8RW1VvIgjeQ06sDGWvxYiU3bUxYmcqgbP7mVKVCrVJWOacjpcBjEYw6HQeApCiFSaIJFJFYqK0LRqw0QYjeoqtayr1a/RbAyCZAPsQ1AvzKqtOo3mWlr+wtZWFUTiV9Wxkogay/twoUaCrSKQOAev1U+QLVEdtmuzUAGQuyxSO3QLsOWUi2w+kkgSVORZ2j6DxsmrceFJpERTUvb01E8bi14Ewwn4ZwPYOSf6PGcrGgsLDzQIF67gQYqPuppeSBfqRdm+r5JbtTBCgwIIz5M+TJ35qlyrWDcLVR5C1WOqase24AuWGY9gadUuxzdUYNyvzIxxRWpwYDKeGq3T2n8ETiRWA6HQdIEKCsDg4IMQOqiACjyolog2oTRAVTJFsWThMzrIIKIMDwA2zn8mEpgiZvkZQlorIbzy4SQIXiNLR4XMmNk0uaxmwyM6MiMbTJVAQ4xoSSn+QpBly0yk2TkRVKCCBhFW+eB1NZEy2F5LMjOYIc5lCQEMIo6gQAWrJdIli6eQ4Es8P3zUzVinxUJnkIsYs14lL8FyCjmy1clICDa46WeBO67JJH4cYnKABVTCoIEKLpzQoJVXcqZkQelEABtgHcZU5AUpiAjDCDLo0J2am7LZiYx/8vQICTdyuiGMioRUWoy1FCkIbhPxBOxqsgWlpqKINjkeUooI8kgKVGqQgiSpQYqphDmcyOEFZR0rlqNptcPtmCOSOGiKl7k6iQ0lBaOjiWh1ky42x644Cz7jMBnrvCfqZ293yC5LHoeqTAmDAh5kp0gPD1wraWSXmbikTob+HMLNaqWW+0C4TXb5r6sKYeJusDzFWyur7HxcZDaE0JqmvIiiNki4SiKLrsft/RdBDztcasFGrEVwgsMwWNBqoim+8KUhYBaZ8YgKZDtqqyqz026CVTNCjTWJrZz1yiknUqOmNX/NSwOX7LIizh3HHGsPDWrwQA8tbacD0Qqgh/KOzWZlTUT7pagCmWWeqTeKVE/8HbNDFtNCXQJLo+aQJKAHXuKM7m0Wq4Gy13a9zCbb1A8Sfa6iosrimkgKDj7Qggs9BM5qBJdem8LHqZcyiJu8U2YvoSeMQLgMZ5q9N4uCoE36PrGSEknXaRp/og4cqGC06qDiLj3MNXvN78n+cRfAww8vdn8B3ERf/zvVSz21j+SJ9DDiqRT8kLrEx0a+uLYossWqdpkD2OUUQQEa0MAEHDjAACcGuq40cCjrKJtD8vU97dSrNDyB1ANOMCgVNctSDlNAOCp4lVglQgFlgsEDhmWiH7AATUeTCQPtsTbV1eMhMzCgAU1gAam9LHWr2d6NbjYqr9zwApCyQA8QF0NFWCB9zzlXsnLzu441bEQPyB9BKnACCKQAAgcYFpuEWDaOuC1WIsihDmmQAguQ8YgRpJfxlLW/EPAgA/DTnIAadq1JHe9/q+KXvUI0Iggw4gQpQOEIFqkBDqqrQB4L277soSQb2GCNOpwBCGr+0sQOYkN6QPQgyha1FvO5DX+zqx2mNikx7SUpUawCAeE0YIEoTmmRuFzkxh7Jj1BikIzQyAEmMykCXnryjE1c05/YVkoJnlFREcjB4Bz2gM8oE5BTnMQPqCQDDdDDkhTIJS5lwAE89ZKSyOwgMLv3gmEacAbFfFk658k/eY7yRDiTICmZpbKAIasCqqySBkAARMVRMgcaQJUCCAWYB8hAnItU1RhzwzcnrZOe+FREO91pArWB8o3L5FYnsflKdOrLmYh7iAUCGqFqbqpq+lqfDVBIImmcQANlwuUDcrC40L20fwMbj/7yuE//zc6dBxSKUv4XDYjZIAc5+NQycCP+AkuqyZLLqCq3cqBVS1YVN7bQ0DqSZCJWkONd4krXNZNhAx5Eykq0BBoTK+rJJtFUoosIzkO7mQIxjiSSdK0JSFHRD60toHwvUCMmOXCDG7woAgsQVWYaEFnWVGACIJjABGB4gahySwQi8KFVO/tVrn7VBqHV6jR2ZiG99QZQK/KrWtEVx7l6inXXmtBc+XZSqv0HhY30YAVAYIEUqMCRPYXgjj411OVU4LnZAmBYKsBTaETgBgvIruUa4NhlUJYqEWiAeEnA3QYQ6gaKXWMKsnuD62I3u+IN3EPIy63LRvWyE0gEar1azC5VlVCpJch+vYpV1q42vAC60IYQDCD+Aeu3W0gbKW1TB4K3CrSaEavr1JiRDAWYaZOVYIGygGXJEpO4xBsGjA04y4kVswAELMiADbhCCRtkIANKomx2F5BjxyoCuzihbGMdS16CkCC9OkyBkKeBXceKV7wSuy5ObDwB2FwWx58NAWj/+4z/oha0/C3xV6fRA2XE7nylCFB4e8Kdh4i0lRb07U+RmQ3cXut64ipIakhhmeuS4AYzJZ5ZfQuYHGQATRG4MQgy8MLJZQAELG5HoiNdiafeeAIs4KkinoubUlQgA7cAstogSxruHpYrOm4vaxaAZANCAL7kaOxhQ0AC+IqVII3l1lO5pVmeghnAUUzGab8KYBH+EArCrCVI7HY2jRdoSCQa0ohYNdQxxZH1aDGZ8HbAywOWQkgBLbj1fxobk/eyFydrhuwCbrDNEWSxEuXLwQupMtwJ3DgDv6DyoheRgzAdbbiLGC2KWZUBe2+E0czNxo2fgV0aN2vWOoYvMxzbcP0e2Z0WWDdVqH3dh8h61hdobJdsYG8xG1vLXP6PiYn9ZYZ+6tnKjh+Cn71g8z6DFFJ9IG3/0wMXuMDhKbruAsIVARcQgGgPaG8j2Psf8WL3AIdl8rp37AHrGFJApr6ByguOm3ovsUnDVXQFcBPjRY8WMFzXL6NzcNlF+/B8+56cvRthAxawgBW1pi1ktX4B9vb+hDapecgCOOBOFWhcw1lPRK51XfKygNnx/dWvlvmrDAJT8dbpFq/YYrckzeeKrfpdlp47+AIMVGgc6tY6QXQcnD4afhGUPYBjbyH07qrpvSRwqALwKt4dr1u/l11iIi7twxDIuwIvuLLUPr1oTGfAs+ebgEhyoFlI1xvU+tUsjqOZfEw/l7MF70mu0bX3REj8RLVvNQ1aAPKXCn3d5g0BZWnDa2h8uSwtz8x/Wf54aXB+O/LHFWfGRNuha6DnED3AAzxwZk3VAxjgAnZBIKl3ewtAAh7gbQ4iNwUwbqnGXXrzXvE3ce+FQhRgNO+3AAfwZ81ScGhCDgWXaYqwYpv+1W+YBUOk0AMFh1mHlgjDJTU5kFmglmiZpSaJNndXhllIiGUXwAJVxgzZ9S+/p24vMkMgqH7zx1TTUGt/disNQF+65mUod2yg5S0DVgHGhn//lSLUthwbwnkcBlQP0RtY9UcXwAMYcIdlVjNFh4c74ndL8l4v0AMWFiFyIwk6BnU7xhW1Z3PcpXURACkkcgIfB388AQIgcAIqgEf/8WjYlwzUBwIb8oLhAlUvwAP2VnDJ8AJNGAEscAIYAEOMll+p+Gg5ECUZcEf2BgIYcAIHUAERoFkbN37p8ns1EgwsADkTU4GeYgLutHitQon5o13/8WkMNXlhZm0n93gDhj/+4hZBXjFBUGE6i+ACd/hzgGWHD5gXigd1Sic22fUCOTAmfbSBE8d+YrUItlaAj0gBIvIABcB01lUB0CIcI8BBD/FoTXgh8PgpOdADIKACKfAAD6AAFFAcEqkCvkh91KUDFUkBbfSLcbccJUeEj6YCFEABK0ABxmEBLJAMV9gPP0AAOpACHEABJmACPnCTM8ABOnAClcNeiTVMMyCN6SIaS8YtIfB89vdrYJYTWPUcT3lyNOJR+QOHFUFKlICOsFNGe4gBeah4v7cI79UTGCghiNaFkbUpqfcZeiUDIOF7PgYcudRInwKSoIY6QpNIG7ABI7CXe7kCGwCYKQkBiVb+ACkQmIK5ASlwAhPQA11nbxtCEBOgAiuwAj5QmT7gAxhZCtpFFD9gATOAk5npAzRAmjpkmqV5HO/VajPgjKvSHYtXefj3HI+3ZWcYFtCwZcGmJNkWSNbWSmNVCeT4gHRTnDxxAXfolQACX7cSckR5N33UAuSgY6MGZKRhXTglIuTzXmMZHHMJYsxQcDLWHTZwAhywl32Jnn65niuQAheQASmAkpU5nxugApuFdpAWeomWAplpmf2pAt0ijdxyABBAAaNZmqV5oKaJmhzwZzdAeJhkAuumTIIEWYNWeRi6Xyg3dmwVFmhoVRQqWadTRVgZOcl5oqaXFMPpAhySamb+FQKJqF98hCki9H6RoWPUZhmsIwMq9BzhRQK1RgDitAHFAxgT4AJY1iQrxZfF0UYn8KRlpwIPEJiLSXIQoAB/OZ+X+QAilghMWIuWwQMoeZmYqZk8kV08AQH+SZoHepqZaUCoyUbF1GockJbmg0q2x0xiNptYJZv256EFhTvH40CiMxQnygOwM4CJkJw/N3Hn13QCGiXQiSkpYKN6yHQ5UQE4VR2shCLhxQEQpQDAcmUsFgEQYCYbVF27ZkS/8QvMJ5/0WZnuyQyatZuUeZmjmZnXA1nkxZFvqqA0sAI3CQHWg4kQMAOoaQGlAKFrxFh65DZRpCjZ4XLSMDEldmz+1VqVO7dWFAU/SDGcGOA2EZCcPOBx57cMY+mpLMWjkpJxAporErckEeBQIgIBa6MMKQBRGjABS4JfLUgQIDACEMACyfcCL2asEZmwEHACb1cKFoCY81mZG9BDzNecIYCsuFqmbjQN2ZUCopmrmWkCbdRfKcKsNIAmNkCnx4RK12RtUGl/0bos+FdbdFiV3RGOARc5K7ofvMmoLSp75TOB/zNNmOKP8DV7ykANUacILMBNA1VDNpCv4qQABnkBYfd2wcOTOqACM5lIFYmlWKoBKtlDm/ICsBqxK/AAi2Z2vCmfuDqaboRrLcCMwJqTi1kJIkC3BkQbJksDMzCrUkT+R2UUR9VYQqNEKLslOq9JEUkBG5UxVR+zs6iXnMJno5GpbpUlMTPqIOwqKeC2Y3wnf1BHGo9Ir1hyRirwULkkA0ZDEPdGXeFithqAnovkl4kJmH/5AKrSJCcAsRG7ARhwaOxhAyrQn/3pn8h1AWoKsplJmFP0AuYJpwaECCk7TLfjS20TSnBGrSU1VzWkOQOyDK+lYpSgWqhAN0iilRJ4bg8XlgxEO4P4bZUjKkq7ITdFJo3UnC9FHRClAhzyaEDIYiGAiRE5kQ9gAhRJkRW5nhQgNQ/BkWgrq46kJBbAAYBpvLiKZxdQQL9qAvUTWxEAAr6KoAh6AsXUt3+rOQb+BUkxA1pMknIxWFHfW5UD0ixjJQI9oY1+FViTMJzCBxg4umAA+VIvMKk8yq48qgD0MGSJ6AgJxaO1lHNlEzw5tUgpoInR1G+1GETVliIsEJgY9j8PK7Fk7FLP8QIP4AMluAFv27ys8rE5uUm38gMnoAMQkMbSi0kqMKeLpQKvpA4dIwIwWGPPtQ5jiDoxo2K/wmadcgG2eXM4nBsvYGxa5SlaZk6N4IAYQH83F6NOyF4Vtyl2xrmkLDemdm4tAAGRQkt02BUHAFGLpAIOt4S7q63PmwEF8ABpqz5ImQhqiraX6Z6AAQFqvEQpYJmYmZIAAcc+wAFf5LE3yaYJKs3+qJkCwpACmDQD/msiL1YBkvNCEMYILwBpn/JribBlimCbXGab1DLJqOUpNQxgekMQkTxjkVyzNps05Fgh80Kdgud77bckFdZHMAAB5BVtJ9CWxFM34wBQqotLG1CCPIB8j5ZIQCev6QCPFdCKd4ylG6ADP5wivQvMKXkCBMECJzmrOjCaa3ooBpqrOCmaCLqgM32aNMAB4QYBfcwILxZPBPIDxqZrqKVfL8YC2YgbX9aUzCACQD2Gy4HD+xUBLmzJUq0iUl1dlRdNn1XP0zpBp6MIiKqcX117QOx092jV1oLEZAIh0tLRD9JNP9PFiZxIsMxIFJBQRDpjiZTAfA3+th6NmBvAAdWVswShAxFcmSbgRScpYjMGAsjM0hQQRiHAAcwLsgk60zMAARaAk5n0OCcglFubAjpQd3fHCHVXCoJsiTAWJZZo1I4cT1+21MW0ZeQwhlKdw0Ki1IIQQSIQgVl2C1VFsspxPC/gc2qDGiEYPaxiA8BRJUccIaYiNy05W54kTUOqnrlk0qTCl9z9l7YbmH4pyy/KwhAAsYiJqybAmEz4QirAxiA7A250AsxMzdRsAqOdCmpEmjOQCQ3Qt5gUwr74P8PlHHZnSQV+ASCACEkbT6C1YOfs07392jzh00vtKffMIUP9hjh8yU4dH0GlLKIijvdKRB6UA3z+9Nyd+9zSsrHemEc1AwIPIE4ysAEzLratmw0UwN2AWbvoSZELq1TPVKDJDJgUwAE6CF3h5QIm8NgroALmFQG3qqC/mpPabBMIwtkHpAIH0AMNcALqt5MDPigvVgrdzKHkkJ+1ncMUPg0uXNuWNMmy7ciOq1UN3iygNcn1bCK48ZtejT/dS4A8LEoScwCq9Nyca3WaJkqLWyAsEJEJlUsK0EYilQiW0t2B2ZcnObC8JUX61d7J/AAqkFkgIAm40Vgei6sP4M3K0OjRLOUmMAM64AFpgTZog6wHtN+zZwP+XT29CAJYzbQsUBYv9gOrrWUgEMlObQMK4sivTeq2Xc/+OCzVOOzUDQ6Vk0wKsK1yu3JB3ktXK0y4saVfdcy1x6UCxxV5FRTozQINFmA9TSJvz9dlmKgDoGiAO1dpBxgC7a6sjjuSHGJuLaACLbAapNPu1tNp7EYKDUA3ekYOXL4t+n5cCiTQnaozMOZgZljgP7ghTi3tW13boNUAyF7JG+4pfBF6F3SvcsZJh5tR2aRhLLxhnVRFhVVRzDV89qbqDjbpBqXRGyEWinZoUpVh1Id9UYG558oTpMNCDn9mPdADN+Bs5cYDf6TnMBZHAJ4Kwc6K81bUtsDU/6HOwB3toLLpWEhHhIpK2COOguW9wMlb4ssDr2VP/EMomqf2ryT+nswFVTcWYwFODsyngztoY+IZ9KbELQ6piWszXnbaLFz+SvK38LdygzdQZk9fPgFHVQluhgW7YqDIdqrt64kgb8Eu4c3Sm3zeW1UvVIJ+RC2bTB3Um0SoDdXgATtgAAGQ+7q/+7yf+wKgUd/gAR4wAL1f/MUvAK54Ao6xAwKAAMb//C5QADuwAwTw/Naf+y7QAsK/A8Z/XYRg+zvgAMVvAAdQAODv/NfP+wjgyDBmd5aIwwD3VHYHzssAVcK25lx8TNgkQPtERc30rIBwEXJBGDJoKDhIeMGDwROhGBnxc9BS4LFDgJDQkeD5CRqKYhAz+WO5k2nQwdrq2lHjGgv+wFCQSkAAgPIKy1rzCwwM4GKRueMQnKwcDFBpi2vw6wrws9DigUkQoCzBc529vSxegyIQUIH+kmMTEiH4jgj/fhEhUhi/WJg/v58fqejvkMBEhgoaPIiP3yKAAPXt64Eh4guGhCY5y4YilMaNCQw0oIQKmsZOrDi54hSgwLNcJHn1ipXMXKVbAsbBXBagEqZMAWoGQ+HsFoFoyQD0+MbTpk0ADOMdTLRwkQh3URc2rNqvn8CtBeUh/GrQH9amUK9GiIiBqqIXLlpguJTNAce5oAxQUomLAA5OfEl68tsSwUoBEly2ShDr8C9ab7MBkCatFTBYwTogIHHtEq7HyQz+XMokgDOzDwcW2MokWqkyA/MQXT0kz2HZfa+z6vun0DVXsLyv8lMUgeqFBjx68GggfHhEF1QjuHARUWU2nhpRILiOfZPGZtcyaQLVCYD48eTHh0QA4HDJEuzbuy8hQQCCFiemr0pcw0D5/eInWeuuCWWUAaDZUJQJ80IPF4GmzH4MLCOBWLc9JZtWirBjm4QZ3kOQU7r1hhAhPUQwYlURFNfDBS80EhGKikCEAXOEsLVcdN7lopEBAuzIo3zbWZPNUH158kEGRrrjjg02UDJAARZsJgAvAARAZZVWVnnCCS08iUuUkQEQwyA2EGIDCxmwEIEDYb5AgmkroZAMAuD+cBNABA3odIsEygTQ2A4M6LhMVb4FlCFw9GgFVWtcWVXhbLBtuA+NaBVXyIloPfccWjFCcgGMLizCIg8rHoCBB3kZEAoOALxwwGeb7QVKM6Z5B8CQAuSQwQQZYEgICFmiospfrQhQAQi6VhDCC0ZmUEGuIFQCIAF6+tJBAA6JyasgFoWUS2U1IEAAAz4xE8GoACKwTAynqITaMo8iGpyEg7Dww4UiiBCCCOzARlFChTol26CQXhBjpmg1sIimGPQwiHOX0gPjIyIWF8JHb90I6ycGIECiq5oIEAoAQHoH8l81ANAsCxNU8IINJP4aEgMuBZBBDsVWcIENzRppJg/+B7hw2lAw9eIAbbclUi5mAI4rjNA/AUDPD5i5mtovApzYwjfdKgNbBTmoRY8IIODsmw0g2DNIA/ZccK+F1/LbkGvXNjpwPi9UxGJaiEAXYwMAnbUcxMu50w6J0ElH8nZRe7xjKAFkHaQEfKEUXK4TqKxylkDvoAJLrwgwUUWJ0tOOgpBv9lIHKNSNyEd4MpjMgcBYG3VQ0DQYwQ2WYLN1MBE2PHYEY74TAc4z1uPODyAs7869Y+Zbb2zwCBybvxTV3Q+nIeSdIj0Pz+Pwwu2EisiKfKtUQF4BaGTtip/xVLLGkGeyCWCsdaryBJcv3xbVLcECNUQVxGUgCVp6boL+AN2IpSE5IMFFbqcUAxyCVQ8MVzIksCqfUU0ZJSBTBEBwt0go6W4qYsHyKlCm5bGAEG0bRNv+RT3aDORDIAIL4ba3HBICLiJqaQffeEAPvn2qUwfrweFopREHGO5iqAvFB3ZHnU90Aio5yMGIEnQAnZiKABlxhTkicQ98sCprg0kMALFXkRfozlXhGId8KkIcPBEAGZ1BQAGzwTSrvaNYa3uH2Vigs7O9oAKAFNsKWSicF2pokYvqEL8cWUMKMQItwrkUpwQXEYaFD4hEjAipSnUj7XwCBWhxyzMGkBFQCMAammFAeqS4ut+kLYuuQsArThYD28SjXNDKBrogU4P+AAzEaAx5gdR2hws4iUMCtDvRAmg5p6LYqYJ6KoogAimcQbxgbBcwYRWFdwE+zmgqi/hBH3PTlYEpMJKRnAff0pKwSSFnRZPCW4tEhBbp8I4AMciYJwTgFkt8xgG1ChkZ4deJv5SjRz1CQGgKVKuSsEIAvEOPBC6KUYyWAADI1MbQYsHQkArABl8j3hg3uAz9AMd1ISGoMhhw0mwQJU420NcBQECbYrEjAiwwYfBMuLYWshBRRJ3N9NIJN3aGCFSDq4jCFOaCHkykdDxcyzvdgkeNyCekJdgIQKn2FyneJHY7WskqXFECdu2gJ5C5ZVq7Q1DJyE4cAsgACDLAqaT+HXQoMwWGABhwiHLxYGrgyKMEfnBMAypDAM4zWw7A2M0V2iB0H1zhCYVnTqmc8zX+0uUMaahUg1zync25VN4yqb3xMQwqL4hjAQC0vrmcpDpTewaqworbsJIEAIIh2f8EwK5cTEsWrUBBzO7zkrGm7mTMekG8agdFB/R1MeBT0LocU02/vkAEe3WAMpmxDpJykyE9zRmaagqCHFxAhfZ4YT0a5ZthEqo1jEJjVl4UoxJ5L0aPKJdzBaWQRUwCcqYiKF3oEpqDZqIECR3SkBLaAY4WqDCSIdAW09MLlxDoGQAowUeplVxhFKIBCyABCRLL4V8y4x4NIA6QZLqaU1z+o0vT/cX9wple4YGTpz8I5PLORghC/qB5QUWbh4yGZPjSzb5RQURwhLPD7omOLIIql4x5FwBRHjgU17mLZkTZ4AS8hz0SKEE5XIWqV6SEw128JSs2rAq5wgI+Za4zncsh4BssgJXYQM1c9ThiE1NzsQ69DmHEwZRy/liF5q1Uy0h4tPfei3BI7ld8IXs9Jie5yeVajpQDTD07rdExGsGBP0GBg9DUKbHg0C0G39YOGUNUPZahxzRbdRpbZri3mdgFfiSAAEgua3h53nOQDJBdZSRQRAvo3zMepBpEBzsRIvCakpCqy36QExL4iO+GAEZfTcOwKp5imPXC+C5eCjT+WCEbD/t0FBzEzg9HqqyT0aYZ3VcexgENA0l31vqKDxQIMS8Z6btCYFe8RmXA0apaMqw1iB60CYoejTadQoAhJ2N70/W9r8cLhe5HhpY3TW6IpVZbIbI4xZgVvG1dtpjKT0A8WcfcCQGiZDIA8DsrIljXM3b0Cgmgw64gIONOHjOsAp31Jonuh13Vm4/cwSUTLl1KAk/kAm/0uXcWt5owwy3fgLxLeov8eFjWuZuRg6V6YPxQthVICNfB5eYakcA+C6oxTlHw39Jy3AKSo2NK4Bo1DA4MCDJ3AvQZI0q+INAtkP6SABA7H7mCND1wbXOkK4UpzjkAZmyeR6VgEEz+ZMeKoCBLEHVib+1JVbskR9fZAC9QEqyOoir7vNZUNYxN845fQgVwAwE3S3+/Cq6+fWGAnbLgBBbwGIVjkRLfZvhbWYmArohNYqS0qyihF4AgPvLiTCTbxoZmAALMzwDANpKocQtLk0Ete7ajvSygdX06kzz2oh4q6oiVI941lgqgoRHBti1spBEfgDCDkAM9dXhZMnV09wpQ40Po40v40REFUhPTFyaxYQO6IhwkNjJzFHoBIC3KkEtxtDTu8n50E3ZgR0z3dX8t+HEAtmTiZnpxI0v0FQI9ABEyYggshxRCgmoAsANBcmrD4DMVVFAlEUuDoD8ToF4rwnyD8T/+J1M8GZAlzbcTAZBhEmABvjR9qtN2M3J9M7JnWiM0BxIa20cuDUBYptJGwLBsl7Z68cdxOohp62eHcmODmpZ/8UdaiwCERshlAhCAIqFKBmAJFMdFIbMIFTABICQmECEduEBhrkAzFcADiaeFOxAa1AJcczJ9AXR/4UQVxrRXnxgMJeAZSRETk+ANimVN2faCHNd+8MeH06N68mJ6fchIs8chZiFElbJGQhE/n2BhmbcdpeIBeDFH4JEATBECOeACZRhvmPeMVcgUPQACGNCJuVB4bzZr1LJRR2NraSRr6TMAXsIMwMJFyuAApeGO3/ULCHBjMgRydyhAjCRfcFP+dpjmi0yWf+XCg8lxAUJEOBCBe5uhVZcwd8foCaOADQY4OQnAMe2gPyBkZZZgABVlEiYBQFdCJRg2NAEQJD7hC2/kZM4VHC+QIAKwIAZSFN4AIA7HHSlYFALjbX/Ij7h4cKPDfjfYiwGpIY+SIItgRJgCaTskIwfpkFtEb6qkEsgkF6EQYVTyARdmlfzBHz/3P75QAxnVHi7RW7gQjlbDlftBcQEwLcBQAggALWxWFISlCnvybSzIi5lWi54Ve/j3WfbHGyRiHCMCZeX2TmgxIj4UOILwForXJaKAPsz4mFaZAClhKvYoRcJSGeoRjbyTZn0hGbHDCyUwYzcHYhb+h0Hn4WvAYAB1cidQ5EoX9DMoFQzet1TmmH9bMTd2qH9CaT1d0XqAeRCH6QiUdVr9xQNC1F/1RAjJ2T95kSMRYXSowRFyYiq6UJFhBpIfeYECaBjf6UVshB+3JA4dIACtOEfThQBhsi2lWWOPs095hAI6ST3dVoO02Iul+Hb0J5wgwoPHOSMsElXgsxxAtEkj9oC4sIwegAF7xVtatXX/F2YlAZqcIAEC5xjhCJrg2QEb9XMHtFyyMJ4RNgCpgB5guRgFAYRv0hkUtUXjJwBfsUC4+TaJgno1GENGhY9e0Z9f4Q486GkV8UOA9zBRNiPR4THL2KDrpgn/909ollv+2RmlXwUOx0drxNULrfkZ9ghiYYgfk2GZQ6FiA1IIbGI7TuNXABAk9FgD3leHLUifHpeLtVFpKfdIRKlLL1CgP8g3nzYIQRo+KeI+BRAdW2QlU5Jlhap4a3UlDDA/DiCSkSqSMWCmwGIOkoqpd0QAAyCpiBqpAAWbkTptKtIAR6E1rSmSA4AJl2olBlA0u1ifckp2dGpp+fgbeLoh5WYIgVqYQaqnmaQimpIpz/FJ5oZ1WYcc//BcAWMoh7KsFTE8u4Ek/TA84MQoA5Ek08ohzzUoYJMzPNqtwYgbHfcvulh25CpDR3autQGQuJptMCI+wyFEAyopGBBC8Bo6DSD+rB/orcB5q0Z1PXD6fjMUlG5Tcv+Kn0C5elQme33Zm/C3j3dKq//gsODGm+7qKSRUr46QnJakTdDBHIrQAFnXAwhDPDM6g+HmKP6om/j4FGeno/Lir4dgM2SSL89DKHp5NDHIhwfnfgCbs+mqg/kJKRQrsPXXo5LkKSZrRJl0Wi5gsmtRLlaBg5kmsTk6tLMaMLc6htXDIbyJcSEAidenJBPwPBILcvZZlPcpN3T4r51VsX7YbSKXtGuHT46QkGjBki75rDrarruZsIOyKDAbe0dGsD97nzkTtjqjP0aCLCGgK00xTDtpripnoz+LuOgacjNKp7LaIQqbdnUro0j+A2k7SEkKq7mAq2RDOZSP4roqu7PnmhXXpiS1S7vXBrkiMAGNhXAT0LZsC3uAe6MuG3/ehrr6mbLfJrhHJbqSNHYdC087Sau8CLsJe7CHi7yoO7uLa7uGwA61azM6YyT60oG5kgH3gnG6uzb+qLVUZrkewrM4SIPo9oLs6rlnJ7hI27xVWwiecknZa6Mz2Ll8mbhMNibfmzO1671haxC4K7bV1rhGcn29+4T40rvZQr0Xm7gDbI7Uu3tTVbw/6bBj4bfuCqtlakTdw1kruGkJYbEZ3Ie1uys1hSzfy8Deq8BKIgKWc326uzK5UgH3Ern6ssO5Qr6Re5dfC4NUW7T+sSpgwiFvByBj3tqTimKu8CW/Jsw6VTuuFoK1q1ufw0tMB/y9SoIOumI5tItxMvyE51tT+iPEu6u+b3zERHy++mK2+bIyGByMLJy8RUtUxhQvlZBFwdECDdACQ3YKSjan2iu8lxtyo4uneYh/wZujpfjCucEPShJe31rG+7LANWU5bry7CNGBu8u456srFgzHkKgvRoxxqAyJ5ku+usvHRenEYuGSutS39NAC0BIBLXADhjxNNnDIFyDFd4qb/XjFDSu7WryjvblO6XqLf7ujsHHA+TJ04XXD3bsvb3wsHYhCtkvH+OI8uuvGkLu7rmwDsDzH6Lwy5gyJ+/K56Nr+tX9jst7wtYXDA6LCKxGQRRdACcF8N8E8WQcQzMGRzM9cvMAIyFvcn9FcuOuaeneom/yiw9UGzk84xDQswfjyze1szviCyg0Mx2scxOj8yteXK0piJGsM0vkyw+mbxwPbcTypDy0gIz9AQojsAghdCYglMZfXAuf4AkUt0EMmxcF8efvIjyPcwXLbo45MyYX7mwGhY8kxubFstmML0pAYxG0cxCi0xqFc1kZswzuMymrt0hwN0vqyuAu8uHCNw2Ebs7F3J1AWLz/wWgdw1C3QeQodzFnk15WSNSqSyMH8ywg9CWAD1axruX+sTnUrdjhKi2LsGhw9AaylP5zS1jP+7MbtrD/enMMDZNo0vStBrMMcnQEMXFOgbNplXNawTbsd/L5k4jLDcQCm2gJj9APDccinsC9IotBDhhwXoDQIPSGpJ4MQy8SALMYQPdUIu7VWnD0RAHUBptmRkMYDZL4KrMfni8M1dS/jfLs2bAjqq94YN8vi7cCzbcPfLNfgDcpoFG/IYRwXkDVSXAkfkcgC3QJLcgANMyJ+DdDO5dexdgDHTaNbi9N4+dj6CM0GK5S2MXQZsAiWEzoylMp+NMu2O8cDFOLiqysVnN4O/MnqG9cr/sm4K9/yveKxDWqtk0V3cye7bchKrdzeANCFPdCn0H88Tdh+o3K3+Kauy8H+zj2wIKLBfdi54asWuILGyHIBORDBxNPSe7QyOVNF5hvO7Ey7OxzmKM4OOwzXajxAORzfMX7abH4Q1+bJKyXFBe0zP6AgNnAUvz0IBv7fyI3QlOBcx8EOxOFc3nsBAEDPiCCBbTceCzEesNHo79DoYCQeLVgeiyAeBUwIAYSr86cQy9IVHz4PzBJONfO9XkMQzaJeO7wzZM0O42va6OvaaxzSnwzfb27WuI7epkzr871dXQHoAJ089bKrITDQM8LYWUQJPG3siHXPiSCN7cfpBXHpIVAehnDph04eB5HpLqzt5MHQ+5Dpnb656SS+qr4vuILhe1QzGMcsj6tAZj7+QM1iwek7wzaMDrve5nJt1u9N27wO27E90t5LAmPihrex7Dwt2HBkEXr358P8Xy/rwtgugd8u6aToD5Vu7VCj8ZVe6doO8gSh8a/R7R1f8ZH+7Rwf6SvP8gEE7pc9EDaDQsyiXmL70tfELMNTRVsrvuhN7yIu3mkOyucN3+gd8PON9DDewDesNm6owySAL1IcRqYA6MZU0DyNzCQAHHeDWNk08Ub18de+8dej8SAf9kxh8huf8aQInBu/7WM/9mlP7dLo8Wj/6HXv9tGem2GkM6iOK2T99xIPlP8QvmV9wwWR0gE/9LP+FfoOFrKu7+T91jdQuwU/CWxzAz/Q9Pj+Ag86NGTlcgNzfk2CovDGGyIULwjdfvHB+PGpr/KuP/baHvvQzvaPku1qn/d0/+hwf+0j3/t67+1tH07ogAgK7DVk475kUkWH0PcufvTabMHefPi8zu/8Tt46nM35gr71IAJqgy+IpSRqkzMkMAkuybfHQwiI1fVkcq1zQ2ksbOkSWO3jTvstX/LbnvLTnv8UPwh1r/v8DwghgoMAAIKFhoWDIYqHhoSPixeTlCGTkhchNpmcFzkVOZKCl5c2OZuDOaGai4s2rDavrbKCtK21rLMhIiKCDSIRvJYNv7sNIRG/wcovoyINERcRP83DEZatmdjblZSclt7e26OjjYz+jReF2pOI6IjriODnAN3p7Zbq55nv5vfzj/H+nVt0z9ytQesukdM2CFSOTvLGfYtlAxTDQbFg4TqYC9YrWbZyiZBVDFmEZA0u2FAW4UWvCy+SnXTZbNKLH9FaRvv2jRw2Ugwv9jzYCSi+bvIeKRwFMeg6bhfHgSPlUx7PcFizat26deFPnlMZnnoYFKHVTKYy2gp58OOiXh9twN0oVy2wUdUuiEAbQe6kk9F8tZzU4AXEwGGZhvP602dCUU4VPmXEmN7XiFWvnsXcc7HmqWG5ih7d9THVxrMexoLYuBLGjmozvt7FdtfIWnUFzc2N669vS4B3Ar50sihmTK1BA3WVjTqq88StxYlzvLks9KWMpYPVTrq79+kSkYJXSRE1t3G10bvCvR4uRdm6c8mmtIlSYPvQsyFlCnrh9M7nIZcNQq5RJRlU1zEWXXXWKbbUZPV8J+FoET31oDdu1WeafmZxxJFs8L2HGy0gukXKTsxJ0xSBB4Z2YIOsXXaZZ9Jhchp/LB5341D8YSUjdVFJ5eGQRBYpSCAAOy==} 1533 1534 1535 1536 1537#============================================================================================== 1538# Make Regexp 1539#============================================================================================== 1540namespace eval make-regexp { 1541} 1542# Takes a list of words, returns a list "prefix <recurse> prefix <recurse> ..." 1543# after grouping by first common letter. 1544proc make-regexp::prefix {words} { 1545 # init 1546 set result {} 1547 lappend words "" ;# to force last completion 1548 # group by first letter 1549 set prefix [string range [lindex $words 0] 0 0] 1550 set subwords [list [string range [lindex $words 0] 1 end]] 1551 foreach word [lrange $words 1 end] { 1552 set char [string range $word 0 0] 1553 if {$char == $prefix} { 1554 lappend subwords [string range $word 1 end] 1555 } else { 1556 # compute prefixes recursively 1557 set recurse [prefix $subwords] 1558 if {[llength $recurse] == 2} { 1559 # only one prefix, so concat with previous prefix 1560 append prefix [lindex $recurse 0] 1561 set recurse [lindex $recurse 1] 1562 } 1563 append result " [verify [list $prefix $recurse]]" 1564 set prefix $char 1565 set subwords [list [string range $word 1 end]] 1566 } 1567 } 1568 # return 1569 set result 1570} 1571# Verification of regexp. 1572# After searching common suffixes, some patterns grouped by parenthesis or conditional exps 1573# may be broken. We need to fix them. 1574proc make-regexp::verify {exp} { 1575 set orphans [isOrphans $exp] 1576 set result {} 1577 foreach {prefix recurse} $exp { 1578 if {![isBalanced $prefix]} { 1579 if {[llength $recurse]} { 1580 foreach {pp rr} $recurse { 1581 lappend result "$prefix$pp" $rr 1582 } 1583 if {![isBalanced $prefix] && $orphans} { 1584 set result [verify $result] 1585 } 1586 } else { 1587 lappend result "$prefix" "" 1588 } 1589 } else { 1590 lappend result $prefix $recurse 1591 } 1592 } 1593 # return result after fixing 1594 set result 1595} 1596# Check for orphan grouping ('|' lost in lower level) 1597proc make-regexp::isOrphans {exp} { 1598 set orphan 0 1599 foreach {prefix recurse} $exp { 1600 if {[string index $prefix 0] == "|"} { 1601 set orphan 1 1602 break 1603 } 1604 if {[isOrphans $recurse]} { 1605 set orphan 1 1606 break 1607 } 1608 } 1609 set orphan 1610} 1611#============================================================================================== 1612# Check if parenthesis in 'str' after balanced. 1613proc make-regexp::isBalanced {str} { 1614 # if start with '?' skip it 1615 if {[string index $str 0] == "?"} { 1616 return 0 1617 } 1618 # must start with a ')' 1619 if {[string index $str 0] != ")"} { 1620 return 1 1621 } 1622 # try to balanced each ')' with an appropriate '(' 1623 set depth 0 1624 foreach c [split $str {}] { 1625 if {$c == "("} { 1626 incr depth -1 1627 } elseif {$c == ")"} { 1628 incr depth +1 1629 } 1630 } 1631 return [expr $depth == 0] 1632} 1633# Check if 'str' contains a first level grouping 1634proc make-regexp::firstLevelGroup {str} { 1635 set depth 0 1636 foreach c [split $str {}] { 1637 if {$c == "("} { 1638 incr depth -1 1639 } elseif {$c == ")"} { 1640 incr depth +1 1641 } elseif {$depth == 0 && $c == "|"} { 1642 return 1 1643 } 1644 } 1645 return 0 1646} 1647#============================================================================================== 1648# After having found common prefixes, try to find common suffixes in expression 1649proc make-regexp::suffix {list} { 1650 # end of recursion if empty list 1651 if {[llength $list] == 0} { 1652 return "" 1653 } 1654 set newlist {} 1655 foreach {prefix recurse} $list { 1656 set result [suffix $recurse] 1657 lappend newlist $prefix [lindex $result 0] 1658 } 1659 # compute longest common suffixes 1660 set words {} 1661 foreach {prefix tail} $newlist { 1662 if {[firstLevelGroup $tail]} { 1663 set tail "($tail)" 1664 } 1665 lappend words [reverse $prefix$tail] 1666 } 1667 set words [lsort -unique $words] 1668 set reverse [prefix $words] 1669 # compute regexp from precomputed reverse list 1670 set regexp [build "" $reverse] 1671 # returns computed regexp 1672 set regexp 1673} 1674proc make-regexp::build {mainstem reverse} { 1675 # flag to indicate need for '?' (optional group) 1676 set addQuestionMark 0 1677 set regexp "" 1678 foreach {prefix recurse} $reverse { 1679 set stem "[reverse $prefix]$mainstem" 1680 if {[llength $recurse]} { 1681 set fromlower [build $stem $recurse] 1682 } else { 1683 set fromlower "" 1684 } 1685 # build regexp 1686 if {$prefix == ""} { 1687 set addQuestionMark 1 1688 } else { 1689 if {[string length $fromlower] > 1 && [string index $fromlower end] != "?"} { 1690 set fromlower "($fromlower)" 1691 } 1692 append regexp "$fromlower[reverse $prefix]|" 1693 } 1694 } 1695 # remove last trailing '|' 1696 set regexp "[string range $regexp 0 end-1]" 1697 # add '?' if needed 1698 if {$addQuestionMark} { 1699 if {[string length $regexp] == 1} { 1700 set regexp "$regexp?" 1701 } else { 1702 set regexp "($regexp)?" 1703 } 1704 } 1705 # result 1706 set regexp 1707} 1708#---------------------------------------------------------------------------------------------- 1709# Last pass for grouping '(x|y|z|...)' into char range '[xyz...]' 1710proc make-regexp::optimize:charset {regexp} { 1711 set optimized "" 1712 set memory "" 1713 set ok 1 1714 set charset "" 1715 # examine char one by one 1716 set len [string length $regexp] 1717 for {set i 0} {$i < $len} {incr i} { 1718 set char [string index $regexp $i] 1719 append memory $char 1720 if {$char =="("} { 1721 # start of group 1722 if {$ok} { 1723 append optimized [string range $memory 0 end-1] 1724 } 1725 incr i 1726 set result [optimize:charset [string range $regexp $i end]] 1727 append optimized "[lindex $result 2][lindex $result 0][lindex $result 3]" 1728 set memory "" 1729 set ok 0 1730 incr i [expr [lindex $result 1]] 1731 continue 1732 } elseif {$char ==")"} { 1733 # end of group 1734 if {$ok} { 1735 set optimized "\[$charset\]" 1736 return [list $optimized $i "" ""] 1737 } else { 1738 return [list $optimized $i "(" ")"] 1739 } 1740 } 1741 if {$ok} { 1742 if {$i & 1} { 1743 if {$char != "|"} { 1744 set ok 0 1745 append optimized $memory 1746 } 1747 } else { 1748 append charset $char 1749 } 1750 } else { 1751 append optimized $char 1752 } 1753 } 1754 # return result 1755 list $optimized $i "(" ")" 1756} 1757#============================================================================================== 1758# Compute string in reverse order 1759proc make-regexp::reverse {string} { 1760 set result "" 1761 for {set i [expr [string length $string]-1]} {$i >= 0} {incr i -1} { 1762 append result [string index $string $i] 1763 } 1764 set result 1765} 1766#============================================================================================== 1767proc make-regexp::make-regexp {words} { 1768 set words [lsort -unique $words] 1769 # escape special chars used to form regexp 1770 regsub -all -- {\|} $words "\x01" words 1771 regsub -all -- {\(} $words "\x02" words 1772 regsub -all -- {\)} $words "\x03" words 1773 regsub -all -- {\?} $words "\x04" words 1774 regsub -all -- {\[} $words "\x07" words 1775 regsub -all -- {\]} $words "\x08" words 1776 # do it 1777 set list [prefix $words] 1778 set regexp [suffix $list] 1779 # returns regexp 1780 set regexp [lindex [optimize:charset $regexp] 0] 1781 # un-escape special chars used to form regexp 1782 regsub -all -- "\x01" $regexp "\\|" regexp 1783 regsub -all -- "\x02" $regexp "\\(" regexp 1784 regsub -all -- "\x03" $regexp "\\)" regexp 1785 regsub -all -- "\x04" $regexp "\\?" regexp 1786 regsub -all -- "\x07" $regexp "\\\[" regexp 1787 regsub -all -- "\x08" $regexp "\\\]" regexp 1788 regsub -all -- "\\*" $regexp "\\*" regexp 1789 regsub -all -- "\\+" $regexp "\\+" regexp 1790 regsub -all -- "\\\$" $regexp "\$" regexp 1791 regsub -all -- "\\\^" $regexp "\\\^" regexp 1792 # returns result 1793 set regexp 1794} 1795#============================================================================================== 1796 1797