Beefy Boxes and Bandwidth Generously Provided by pair Networks
laziness, impatience, and hubris
 
PerlMonks  

comment on

( [id://3333]=superdoc: print w/replies, xml ) Need Help??
I decided to have my first look at Tk, and in doing so accidentally wrote the following regex tester. (matches only, no transliteration or replacements, perhaps the next version... :) )

I thought it actually turned out to be fairly useable, so I offer it here to any monk that may find it of use.

It couldn't be much simpler, so all I shall say is this...

You don't delimit the regex, no need to type '/.(.)/', just omit the slashes (Internally it will put forward slashes on there for you, and automagically escape any forward slashes you're matching in the regex).

I've tried to make the update of the results intelligent. If the previous regex took under 0.1 seconds to run, the subsequent update will be immediate. If it took over 0.1 seconds, the update will be delayed by three times that run time. For example, if the regex completed in 0.2 seconds, the delay will be 0.6 seconds. The delay is capped at 1 second. If this second update style is evoked, the result window will be cleared immediately, to give a clear indicator that your regex is now taking significant time to run.

Updates following changes to the switches are always immediate.

You need Regexp::Parser, which I've used to determine the number of captures to display in the results window.

CAVEAT: This is my first Tk script. This is _not_ an example on how to program in Tk. Feel free to (comment on|criticise|praise) my 'style'. Enjoy, Rob.

UPDATE: Bug fix following liverpole's comments. See replies...

#!/usr/bin/perl -w use strict; use warnings; use Tk; use Tk::LabEntry; use Tk::Text; # needed for a pp compile for some reason use Time::HiRes qw( time ); use Regexp::Parser; my $last_run_time = 0.1; my $update_display_timer; # global widget values my $regex_text = ""; my $regex_text_old = ""; my $data_text = ""; my $data_text_old = ""; my $check_switch_i_value = 0; my $check_switch_m_value = 0; my $check_switch_g_value = 0; my $check_switch_s_value = 0; my $mw = MainWindow->new('-title' => 'MPC Regex Tester', '-width', 400 +); # SWITCHES my $switch_frame = $mw->Frame()->pack('-expand' => 0, '-fill' => 'x'); my(@pl) = qw/-side left -anchor w/; my $switch_label = $switch_frame->Label('-text' => "Switches: ", '-an +chor' => 'w')->pack(@pl); my $check_switch_i = $switch_frame->Checkbutton( -text => 'i ', -variable => \$check_switch_i_value, -relief => 'flat' )->pack(@pl); my $check_switch_m = $switch_frame->Checkbutton( -text => 'm ', -variable => \$check_switch_m_value, -relief => 'flat' )->pack(@pl); my $check_switch_s = $switch_frame->Checkbutton( -text => 's ', -variable => \$check_switch_s_value, -relief => 'flat' )->pack(@pl); my $check_switch_g = $switch_frame->Checkbutton( -text => 'g ', -variable => \$check_switch_g_value, -relief => 'flat' )->pack(@pl); my $spin_box = $switch_frame->Spinbox( qw/-from 1 -to 100 -width 5 -validate all/, '-validatecommand' => sub { my ($proposed, $changes, $current, $index, $type) = @_; return 0 if $proposed !~ m/^\d*$/; return 0 if $proposed and $proposed > 100; return 1; }, )->pack(@pl); $spin_box->set(5); $spin_box->configure(qw/-state disabled/); # REGEX ENTRY my $top_spacer = $mw->Label('-text' => " ", '-anchor' => 'w')->pack(' +-fill' => 'x'); my $top_frame = $mw->Frame()->pack('-expand' => 0, '-fill' => 'x'); my $regex_label = $top_frame->Label( '-text' => 'Regex: ', )->pack('-side' => 'left'); my $regex = $top_frame->Entry( '-textvariable' => \$regex_text, )->pack('-side' => 'left', '-expand' => 1, '-fill' => 'x') +; my $right_spacer = $top_frame->Label('-text' => ' ',)->pack('-side' +=> 'left'); $mw->fontCreate(qw/C_norm -family courier -size 10/); $mw->fontCreate(qw/C_norm_b -family courier -size 10 -weight bold/) +; # DATA AND RESULTS PANED WINDOW my $data_label = $mw->Label('-text' => "\nData: ", '-anchor' => 'w')- +>pack('-fill' => 'x'); my $pw = $mw->Panedwindow(qw/-orient vertical/); $pw->pack(qw/-side top -expand yes -fill both /); my $data = $pw->Scrolled(qw/Text -setgrid true -width 70 -height 4 -f +ont normal -wrap word -scrollbars e -font -adobe-courier-medium-r-nor +mal--12-120------1/)->pack(qw/-expand yes -fill both/); my $results_text = $pw->Scrolled(qw/Text -setgrid true -width 70 -hei +ght 10 -font normal -wrap word -scrollbars e/)->pack(qw/-expand yes - +fill both/); $results_text->tag(qw/configure norm -font C_norm/); $results_text->tag(qw/configure bold -font C_norm_b/); $pw->add($data, $results_text); # BINDINGS $check_switch_i->bind('<Button-1>', sub { button_run('now') }); $check_switch_m->bind('<Button-1>', sub { button_run('now') }); $check_switch_s->bind('<Button-1>', sub { button_run('now') }); $check_switch_g->bind('<Button-1>', sub { if ($check_switch_g_value) { $spin_box->configure(qw/-state normal/); } else { $spin_box->configure(qw/-state disabled/); } button_run('now'); } ); $spin_box->bind('<ButtonRelease-1>', sub { button_run('now') } ); $spin_box->bind('<KeyPress>', \&update_display); $regex->bind('<KeyPress>', sub { if ($regex_text ne $regex_text_old) { $regex_text_old = $regex_text; button_run('whenever'); } }); $data->bind('<KeyPress>', sub { $data_text = ""; my @data = $data->dump('-text', '0.0', 'end'); while (scalar @data) { my ($type, $string,$i) = (shift @data, shift @data, shift @dat +a); $data_text .= $string; } if ($data_text ne $data_text_old) { button_run('whenever'); $data_text_old = $data_text; } }); #===================================================================== +========= MainLoop( ); #===================================================================== +========= sub button_run { my ($method) = @_; $update_display_timer->cancel() if $update_display_timer; if ($method eq 'now' or $last_run_time < 0.1) { update_display(); } elsif ($method eq 'whenever') { # set a delayed event for the display to update my $update_delay = ($last_run_time * 3); $update_delay = 2 if $update_delay > 2; $results_text->delete('0.0', 'end'); $update_display_timer = $data->after(int($update_delay * 1000) +, sub { button_run('now') } ); } else { warn("unknown update method"); update_display(); } } #===================================================================== +========= sub update_display { my $start_time = time; if ( length($regex_text) == 0 ) { $results_text->delete('0.0', 'end'); } else { my $switches = ""; $switches .= 'i' if $check_switch_i_value; $switches .= 'm' if $check_switch_m_value; $switches .= 'g' if $check_switch_g_value; $switches .= 's' if $check_switch_s_value; my %data; my $error_text; if (! run_regex (\%data, $data_text, $regex_text, $switches, \ +$error_text) ) { $results_text->delete('0.0', 'end'); $results_text->insert('insert', "Warning: ", 'bold'); $results_text->insert('insert', $error_text, 'norm'); } else { $results_text->delete('0.0', 'end'); if (! $data{'A_MATCH'} ) { $results_text->insert('insert', 'No Match', 'norm'); } else { $results_text->insert('insert', "Match\n\n", 'norm'); if ($data{'CATCH_COUNT'} > 0) { my $results_index = 1; while (exists $data{"RESULT_SET_$results_index"}) +{ my $results_ref = $data{"RESULT_SET_$results_i +ndex"}; $results_text->insert('insert', "-"x70 . "\n", + 'norm'); $results_text->insert('insert', "Result set $r +esults_index\n", 'bold'); foreach my $capture_index (1..$data{CATCH_COUN +T}) { $results_text->insert('insert', "\$$captur +e_index: ", 'bold'); $results_text->insert('insert', $results_r +ef->{"CATCH_$capture_index"} . "\n", 'norm'); } $results_index++; } } } } } $last_run_time = abs(time - $start_time); } #===================================================================== +===================== sub Tk::Error { my ($widget,$error,@locations) = @_; $results_text->delete('0.0', 'end'); $results_text->insert('insert', "Warning: ", 'bold'); $results_text->insert('insert', $error, 'norm'); } #===================================================================== +===================== sub run_regex { my ($data_ref, $data, $regex_text, $switches, $error_ref) = @_; my $catch_count = 1; my $parser_eval_result = eval { my $parser = Regexp::Parser->new($regex_text); $catch_count = scalar @{$parser->captures()}; return 1; }; if (! defined $parser_eval_result) { $$error_ref = $@; return; } my $max_results_set = $spin_box->get() ? $spin_box->get() : 1; $max_results_set = 1 if $switches !~ /g/; $data_ref->{'A_MATCH'} = 0; $data_ref->{'CATCH_COUNT'} = $catch_count; $regex_text =~ s|/|\\/|g; my $eval_result = eval(" \$data_ref->{'WORKING'} = 2; SET: foreach my \$result_set (1..\$max_results_set) { if (\$data =~ m/$regex_text/$switches) { \$data_ref->{'A_MATCH'} = 1; \$data_ref->{'RESULT_SET_' . \$result_set}{MATCH} = 1; # following line commented out because I wasn't doing anyt +hing with the value #\$data_ref->{'RESULT_SET_' . \$result_set}{MATCH_OFFSET} += pos(\$data); foreach my \$capture_index (1..$catch_count) { \$data_ref->{'RESULT_SET_' . \$result_set}{'CATCH_' . +\$capture_index} = eval('return \$' . \$capture_index); } } else { last SET; } } return '1'; "); # return error if the eval failed if (! defined $eval_result) { # hopefully error will just be a bad regex, clean up the messa +ge if so. # otherwise just spit the lot out. if ($@ =~ m/^(.*) at .+ line \d+\./s) { $$error_ref = $1; } else { $$error_ref = $@; } return; } return 1; }

In reply to A graphical regular expression tester. by reasonablekeith

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":



  • Are you posting in the right place? Check out Where do I post X? to know for sure.
  • Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
    <code> <a> <b> <big> <blockquote> <br /> <dd> <dl> <dt> <em> <font> <h1> <h2> <h3> <h4> <h5> <h6> <hr /> <i> <li> <nbsp> <ol> <p> <small> <strike> <strong> <sub> <sup> <table> <td> <th> <tr> <tt> <u> <ul>
  • Snippets of code should be wrapped in <code> tags not <pre> tags. In fact, <pre> tags should generally be avoided. If they must be used, extreme care should be taken to ensure that their contents do not have long lines (<70 chars), in order to prevent horizontal scrolling (and possible janitor intervention).
  • Want more info? How to link or How to display code and escape characters are good places to start.
Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others having a coffee break in the Monastery: (4)
As of 2024-03-28 15:50 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found