#!/usr/bin/perl

use strict;
use Tk;

use constant WIDTH=>80;

=pod
=head1 NAME
       PREP - Practice Regular Expression in Perl!

=head2 Version: 1.0

=head2 Date: 4/25/02

=head2 Author: Dave Turner dave@wrightpopcorn.com
                           
=head1 SYNOPSYS

=head2 This program allows a user who is unfamiliar with regular expressions to
       test the various regexes and options on a string to see what the results
       are. The regex is entered by the user, and the options are selected via
       the checkboxes. The m, s, and tr have been implemented.

       The user is then shown the result of their regex on their input. If the
       user has a regex of the flavor m/(www)\.myhost\.com/, the program will
       list the parenthetical matches in order after any other match has been
       shown.

       Note: Input is limited to a single line. This program does not handle
       variables in the input, nor does it work on multiple lines. Also, the 'o'
       option is not used as this is done as a single line to test not an entire
       text file.

=head1 KNOWN BUGS

=head2 At present, when doing a tr substitution, the checkboxes are not being
       disabled. This causes an error message about a bareword on completion of
       the program.

=cut

use constant COLOR => '#FFEDB4';
use constant COLOR2 => '#3396DF';

my ($top, $regex, $user_text, $match_results, $font, $tr);
my $options=' ';
my $i_status=' ';
my $cg_status=' ';
my $g_status=' ';
my $m_status=' ';
my $x_status=' ';
my $s_status=' ';
my $flag=0;


$top=MainWindow->new();
$top->title("PREP - Practice Regular Expressions in Perl!");
$top->minsize( 300, 400 );
$top->configure(-background=>COLOR);

&fontsize(12, 'arial', 'bold');
&fontsize(14, 'arial', 'bold');
&fontsize(18, 'arial', 'bold');

my $title=>$top->Label(
                       -text=>"\nPractice Regular Expressions in Perl\n",
                       -bg=>COLOR,
                       -font=>'code18',
                       )->pack();

my $regtxt=$top->Label(
                       -text=>'Regular Expression to test',
                       -bg=>COLOR,
                       -font=>'code14',
                       )->pack();

my $reg=$top->Entry(width=>30,
                    -font=>12,
                    -textvariable=>\$regex,
                    )->pack();

my $textlbl=$top->Label(-text=>"Enter a string to parse",
                        -bg=>COLOR,
                        -font=>'code14',
                        )->pack();

my $text=$top->Entry(width=>30,
                    -font=>12,
                    -textvariable=>\$user_text,
                    )->pack(-side=>'top');

my $result=$top->Label(-text=>"Results of regex",
                       -bg=>COLOR,
                       -font=>'code14',
                       )->pack();

my $restxt=$top->Label(width=>WIDTH,
                      -textvariable=>\$match_results,
                      -bg=>'white',
                      -relief=>'groove',
                      -font=>14,
                      -height=>10,
                      -justify=>'left',
                      )->pack(-side=>'top');

my $leave=$top->Button(-text=>'Exit',
                       -command =>[$top=>'destroy'],
                       -font=>'code14',
                       )->pack(-side=>'bottom',
                               -anchor=>'se',
                               -ipadx=>10,
                               -expand =>16);

my $frame1=$top->Frame;
my $frame2=$top->Frame;
my $frame3=$top->Frame;

$frame1->pack();
$frame2->pack();
$frame3->pack();

my $test=$top->Button(-text=>'See what it does!',
                       -command =>\&do_it,
                       -font=>'code14',
                       )->pack(
                               -ipadx=>10,
                               -expand =>16);

my $i=$frame1->Checkbutton(
                        -bg=>COLOR,
                        -text=>'Ignore Case (i)',
                        -command=>\&global,
                        -activebackground=>COLOR,
                        -onvalue=>'i',
                        -offvalue=>' ',
                        -variable=>\$i_status,
                        -font=>'code12',
                        -justify=>'left',
                        -takefocus=>$tr,
                        )->pack(
                                 -side=>'left',
                                 );

my $g=$frame1->Checkbutton(
                        -bg=>COLOR,
                        -text=>'Match globally (g)',
                        -command=>\&global,
                        -onvalue=>'g',
                        -offvalue=>' ',
                        -activebackground=>COLOR,
                        -variable=> \$g_status,
                        -font=>'code12',
                        -justify=>'left',
                        )->pack(
                                 -side=>'left',
                                 );

my $s=$frame1->Checkbutton(
                        -bg=>COLOR,
                        -text=>'Let . match newline (s)',
                        -command=>\&global,
                        -onvalue=>'s',
                        -offvalue=>' ',
                        -activebackground=>COLOR,
                        -variable=>\$s_status,
                        -font=>'code12',
                        -justify=>'left',
                        )->pack(
                                 -side=>'left',
                                 );



my $x=$frame2->Checkbutton(
                        -bg=>COLOR,
                        -text=>'Ignore whitespace (x)',
                        -command=>\&global,
                        -onvalue=>'x',
                        -offvalue=>' ',
                        -activebackground=>COLOR,
                        -variable=>\$x_status,
                        -font=>'code12',
                        -justify=>'left',
                        )->pack(
                                 -side=>'left',
                                 );

my $cg=$frame3->Checkbutton(
                        -bg=>COLOR,
                        -text=>"Continue search after failed /g match (/cg)",
                        -command=>\&global,
                        -onvalue=>'cg',
                        -offvalue=>' ',
                        -activebackground=>COLOR,
                        -variable=>\$cg_status,
                        -font=>'code12',
                        -justify=>'left',
                        )->pack(
                                 -side=>'left',
                                 );

my $m=$frame2->Checkbutton(
                        -bg=>COLOR,
                        -text=>'Let ^ and $ match next to \n (m)',
                        -command=>\&global,
                        -onvalue=>'m',
                        -offvalue=>' ',
                        -activebackground=>COLOR,
                        -variable=>\$m_status,
                        -font=>'code12',
                        -justify=>'left',
                        )->pack(
                                 -side=>'left',
                                 );



MainLoop();

sub global{

=head2     We need to check here if we have an m, s or tr substitution as the
           number of // is different. With m we're removing everything after the
           second / while the s and tr we're taking everything off after the
           third /.
=cut
           if (substr($regex,1,0) eq 'm'){$regex =~ s/(\/.+\/).+/$1/}
           else {$regex =~ s/(\/.+\/.+\/).+/$1/};
           $options ='';
           $options = $i_status.$m_status.$x_status.
                      $cg_status.$s_status.$g_status;
           $options =~ s/ //g;
           $regex .= $options;
           }

sub do_it{

my @matches=();

=head2  Since we need to run our user's input through the regex here we're
        concatenating the options. The options have already had the white
        spaces removed before we concatenate them.
=cut

    $match_results = $user_text;

=head2  Here we use the reference to the text that we want to run the regex on
        otherwise it will just evaluate both strings as strings and not change
        the value of the variable we're looking at.
=cut

   if (substr($regex,0,1) eq 's'){
       eval "\$match_results =~ $regex";
       };

=head2  In evaluating the regex for 'm' and 'tr' we want the value of
        $match_results to receive the changed value of $user_text, so we're
        taking the reference to $u\n";er_text.
=cut

    if (substr($regex,0,1) eq 'm'){

    $match_results="m// Matched: ";

=head2 If we've had a regular expression with grouping, we need to show the
       matches we made there too. Unless we count the number of matching
       parens, which could get odd if there was a match looking for '(' and ')',
       we run a simple counter and check if the match variable exists. If it
       does, we print it out. If no parenthesis are used, $match_results holds
       our match.
=cut
       {eval "\@matches = (\$user_text =~ $regex); \$match_results .= \$&;";
             $match_results .= "\n";
             $match_results .= " Variables:\n"if defined($matches[$i]);
             for (my $i = 1; $i <= @matches; $i++) {
                  my $found = $matches[$i - 1];
                  $match_results .= " \$$i:$found \n" if defined($matches[$i]);
                  }
             } # end eval block

        } # end if substr eq 'm'

    eval "\$match_results =~ $regex" if substr($regex,0,2) eq 'tr';
    &chk_res($match_results);
    }

 sub fontsize{
    my ($size, $family, $type)=@_;
    $font=$top->fontCreate(
                           'code'.$size,
                           -family=>$family,
                           -weight=>$type,
                           -size=>$size,
                           );
}

sub chk_res{
    my $text = shift;
    my $len = length($text);
    my $newtext='';
    if ($len>80){
        for my $i (0.. $len){
                   $i%79==0?$newtext .=substr($text,0, $i).'\n'
                            :$newtext .= substr($text,0,$i);
                   print "New Text is:$newtext\n";
                   }
        }
    else{ return $text};

    return $newtext;
    }