#!/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: ",  '-anchor' => '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 -font normal -wrap word -scrollbars e -font -adobe-courier-medium-r-normal--12-120------1/)->pack(qw/-expand yes -fill both/);

my $results_text = $pw->Scrolled(qw/Text -setgrid true -width  70 -height 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 @data);
        $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_index"};
                        $results_text->insert('insert', "-"x70 . "\n", 'norm');
                        $results_text->insert('insert', "Result set $results_index\n", 'bold');
                        foreach my $capture_index (1..$data{CATCH_COUNT}) {
                            $results_text->insert('insert', "\$$capture_index: ", 'bold');
                            $results_text->insert('insert', $results_ref->{"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 anything 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 message if so.
        # otherwise just spit the lot out.
        if ($@ =~ m/^(.*) at .+ line \d+\./s) {
            $$error_ref = $1;
        } else {
            $$error_ref = $@;
        }
        return;
    }
    return 1;
}