#!/usr/bin/perl
use warnings;
use strict;
use Tk;
use Tk::LabEntry;

my $mw = MainWindow->new( -bg => 'black' );
$mw->geometry('100x30+60+15');

my $textin = '';

if(defined $ARGV[0]){
     if(-e $ARGV[0]){ my $file_name = $ARGV[0];
                      open (FH,"< $file_name");
                      read( FH,  $textin, -s FH );
                     close FH;
                   }
}

#assign as many as you want, 10 is pretty ample 
my %tcolors = ( 1 => ['black','pink'],
                2 => ['black','lightgreen'],
                3 => ['black','yellow'],
                4 => ['black','green'],
                5 => ['black','lightblue'],
                6 => ['black','khaki'],
                7 => ['black','orange'],
                8 => ['white','purple'],
                9 => ['white','red'],
               10 => ['white','black'],
);

my $numcolors = scalar(keys %tcolors);

#select default search method 
my $kind = 'multiword'; # or 'exact' or 'regexp' 

#select default case matching 
my $case = 1; #or 0 for nocase 

my $search_string = '';

my $stringframe = $mw->Frame(-bg=>'steelblue')->pack(qw/-side top -fil
+l x/);;
my $ss = $stringframe->LabEntry(
                -label => 'Regexp:',
                -bg => 'lightyellow',
                -width => 60,
                -labelPack => [qw/-side left -anchor w/],
                -textvariable => \$search_string
                 )->pack(qw/-side left/);

my $ss_button = $stringframe->Button( -text => 'Test It' )
                 ->pack(qw/-side left -pady 5 -padx 10/);

$stringframe->Button( -text => 'Exit',-bg=>'red',
                      -activebackground => 'pink',
                      -command=>[sub{Tk::exit}])
                 ->pack(qw/-side right -pady 5 -padx 10/);

$mw->Label(-text=>"         Enter your text or file below 
                   (a file can be entered on the commandline)",-bg=>'l
+ightblue'
                )->pack(qw/-side top -fill x/);

my $text = $mw->Scrolled(qw/Text -setgrid true -scrollbars e bg lighty
+ellow/);

foreach my $tag(keys %tcolors){
  $text->tagConfigure($tag, -foreground => $tcolors{$tag}[0],
                            -background => $tcolors{$tag}[1]
                            )}

$text->insert('0.0', $textin);
$text->mark(qw/set insert 0.0/);

my $subframe = $mw->Frame;

my $casesw = $subframe->Checkbutton(
    -selectcolor=>'green',
    -text=>'Match Case',
    -offvalue=> 0,
    -onvalue=> 1,
    -variable=>\$case,
    -state => 'disabled'
);

my $exact    = $subframe->Radiobutton(
    -text     => 'Exact match',
    -variable => \$kind,
    -value    => 'exact',
    -command  => [sub{$casesw->configure(-state => 'normal')}]
);


my $multiword  = $subframe->Radiobutton(
    -text     => "Multiword(space separated words, exact case only, $n
+umcolors colors )",
    -variable => \$kind,
    -value    => 'multiword',
    -command  => [sub{$casesw->configure(-state => 'disabled')}]
);

my $regexp = $subframe->Radiobutton(
    -text     => 'Regular expression',
    -variable => \$kind,
    -value    => 'regexp',
    -command  => [sub{$casesw->configure(-state => 'normal')}]
);

$exact->pack(-side=>'left', -fill => 'x',-expand=>1 );
$multiword->pack(-side=>'left', -fill => 'x',-expand=>1 );
$regexp->pack(-side=>'left', -fill => 'x',-expand=>1 );
$casesw->pack(-side=>'right', -fill => 'x',-expand=>1 );

$stringframe->pack(qw/-side top -fill x/);
$subframe->pack(qw/-side top -fill x/);
$text->pack(qw/-expand yes -fill both/);

# tcolor 1 will be the default 
my $command = sub { &search_text($text,\$search_string,'1',$kind,\%tco
+lors,$case)};
$ss_button->configure( -command => $command );
$ss->bind( '<Return>' => $command );

$ss->focus;

MainLoop;

######################################################################
+#3 

sub search_text {
    # adapted from widget demo 
    my ( $w, $string, $tag, $kind, $colorsref,$case) = @_;
      return unless ref($string) && length($$string);

    for my $t(keys %{$colorsref}){
          $w->tagRemove( $t, qw/0.0 end/ );
         }

    my ( $current, $length ) = ( '1.0', 0 );

my $stringw;
my %tagcols;
my $multiflag = 0;
if($kind eq 'multiword'){
          $kind = 'regexp'; # going to search multiwords as regex (x|y
+|z) 
          $multiflag = 1; # workaround flag for runaway regexps  

          my @strings = split /\s+/,$$string;
             if((scalar @strings ==0)){print chr(07);return}

          #make regex chars literal with separate parallel array of re
+gexes 
          my @stringsrx = map qr{\Q$_\E},@strings;

          my $str = join '|',@stringsrx;
          $stringw = "($str)";
          #map to indices 
          @tagcols{@strings} = 1..($#strings+1);
    }else{
        $stringw = $$string;}

my ($current_last,$length_last) = (0,0);
 while (1) {
    if($case){
       $current =
          $w->search(-count => \$length, "-$kind", $stringw, $current,
+ 'end' );
        }else{
        $current =
          $w->search(-count => \$length, "-$kind",'-nocase', $stringw,
+ $current, 'end' );
        }

        last if not $current;
        #warn "Posn=$current count=$length\n"; 

     #test for runaway regex such as a solo .* 
     if(($kind eq 'regexp')and($multiflag == 0)){
         if(($current == $current_last)and($length == $length_last))
                         {print chr(07);return}
          }

       $current_last = $current;
       $length_last = $length;

     if($multiflag == 1){
          #determine the word just found and get it's tag 
          my($line,$offset) = split /\./,$current;
          my $lengthw = $offset + $length;
          my $word = $w->get($current, $line.'.'.$lengthw);
          $tag = $tagcols{$word} || 1;
          my $numcolors = scalar keys %{$colorsref};
          if($tag > $numcolors){$tag = $numcolors} # set $tag to last 
+color for overflows
        }

        $w->tagAdd( $tag, $current, "$current + $length char" );
        $current = $w->index("$current + $length char");
        $w->update;
    }#end of while loop 
}
[download]