http://www.perlmonks.org?node_id=588360
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;
}