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

A graphical regular expression tester.

by reasonablekeith (Deacon)
on Dec 07, 2006 at 15:25 UTC ( #588360=snippet: print w/replies, xml ) Need Help??
Description: 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;
}
Replies are listed 'Best First'.
Re: A graphical regular expression tester.
by liverpole (Monsignor) on Dec 07, 2006 at 16:00 UTC
    Hi reasonablekeith,

    You should be aware that the following errors occur when matching the regex "a?Cd" against the data "abcdefg" (with no checkbuttons selected):

    Warning: Attempt to load 'Tk::Checkbutton::0.000503063201904297' at /usr/lib/perl5/site_perl/5.8.0/i386-linux-thread-multi/Tk/Widget.pm line 287 Tk::Widget::AUTOLOAD('Tk::Checkbutton=HASH(0x860c6a8)') called at /usr/lib/perl5/site_perl/5.8.0/i386-linux-thread-multi/Tk.p +m line 406 eval {...} called at /usr/lib/perl5/site_perl/5.8.0/i386-linux-thread-multi/Tk.pm line 406 Tk::MainLoop() called at x line 126

    s''(q.S:$/9=(T1';s;(..)(..);$..=substr+crypt($1,$2),2,3;eg;print$..$/
      Weird, your example tested fine until I clicked one of the switches, then got a similar error to you. However, I noticed the error didn't occur when clicking the checkbox for 'g'. The way subroutine call for this event is handled differently, so I swapped the following....
      < $check_switch_i->bind('<Button-1>', \&button_run('now')); < $check_switch_m->bind('<Button-1>', \&button_run('now')); < $check_switch_s->bind('<Button-1>', \&button_run('now')); > $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') });
      ...and the bug has gone. I've no idea why though. Anyone?

      Cheers, Rob

      ---
      my name's not Keith, and I'm not reasonable.
        Hi reasonablekeith,

        Yes, it's because you're not doing what you think you're doing with:

        $check_switch_i->bind('<Button-1>', \&button_run('now'));

        If you run perl -MO=Deparse on that, it'll show you:

        $check_switch_i->bind('<Button-1>', \(&button_run('now')));

        Which means that you're calling bind with a reference to the results of a call to the subroutine button_run.

        What you want, instead (if you're going to use that style of notation), is the anonymous list syntax:

        $check_switch_i->bind('<Button-1>', [ \&button_run, 'now' ]);

        s''(q.S:$/9=(T1';s;(..)(..);$..=substr+crypt($1,$2),2,3;eg;print$..$/
Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: snippet [id://588360]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others examining the Monastery: (3)
As of 2022-10-01 09:14 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    I prefer my indexes to start at:




    Results (126 votes). Check out past polls.

    Notices?