API tools faq
paste
Advertisement
hackbyte

Updated Visual-Regexp

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