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

my $mw  = MainWindow->new(-title=>'Colored Text');
$mw->geometry('200x200+666+266' );

$mw->fontCreate('big',
    -family=>'arial',
    #-weight=>'bold',
     -size => 12 );

my $text = $mw->Scrolled('Text', -scrollbars=>'osw',
                           -background => 'black',
                           -foreground  => 'lightyellow',    
                           -font => 'big',
                           )->pack;

#add colors and font effects
$text->tagConfigure( 'tag1',   -foreground => 'red' );
$text->tagConfigure( 'tag2',   -foreground => 'skyblue' );
$text->tagConfigure( 'tag3',   -foreground => 'yellow');
$text->tagConfigure( 'tag4',   -foreground => 'green' );
$text->tagConfigure( 'bold',   -font => [ 'Courier New', 20, 'bold' ] );
$text->tagConfigure( 'italic', -font => [ 'Courier New', 20, 'italic' ] ) ;

# see regular text
$text->insert('end',"some text\n");
# see tagged text
$text->insert('end',"some text\n",'tag1');
$text->insert('end',"some text\n",'tag2');
$text->insert('end',"some text\n",['tag3','bold']);
$text->insert('end',"some text\n",['tag4','italic']);

MainLoop;
__END__

##</code><code>##

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

our @Red_Keywords = qw(print sprintf);
our @Blue_Keywords = qw(if elsif else my our use sub);

our $Comment = '#|//';
our @Comment = ( "\#", "\//" );

our $All_Keys =
  "print|sprintf|if|elsif|else|my|our|use|sub|while|foreach|loop|split|
glob|substr|length|open|close|chomp|chop|next|unless";

our %Highlights = (
    Red_Keyword  => [qw(red bold)],
    Blue_Keyword => [qw(blue bold)],
    Comment      => [qw(orange italic)],
);

setup_window();

MainLoop;

sub setup_window {
    my $mw = MainWindow->new();
    my $t  = $mw->Scrolled( 'Text', 
             -bg => 'white',
             -font => [ 'Courier New', 20 ] )->pack();

    $t->tagConfigure( 'blue',   -foreground => 'blue' );
    $t->tagConfigure( 'red',    -foreground => 'red' );
    $t->tagConfigure( 'orange', -foreground => 'orange' );
    $t->tagConfigure( 'gray',   -foreground => 'gray' );

    $t->tagConfigure( 'bold',   -font => [ 'Courier New', 20, 'bold' ] );
    $t->tagConfigure( 'italic', -font => [ 'Courier New', 20, 'italic' ] );

    $t->bind(
        '<KeyRelease>',

        # Automatically prepends $t to called sub's args
        [ \&highlight_range, 'insert linestart', 'insert lineend' ],
    );

    # Paste events may include more than one line to be formatted,
    # so we rehighlight the entire text.
    $t->bind( '<<Paste>>', [ \&highlight_range, '1.0', 'end' ], );

    $t->focus();
}

# Remove all formatting so that updates will unhighlight things properly
sub unhighlight_range {
    my $t     = shift;
    my $start = shift;
    my $end   = shift;

    foreach my $style ( keys %Highlights ) {
        foreach my $tag ( @{ $Highlights{$style} } ) {
            $t->tagRemove( $tag, $start, $end );
        }
    }
}

sub highlight_range {
    my $t     = shift;
    my $start = shift;
    my $end   = shift;

    unhighlight_range( $t, $start, $end );

    foreach my $comm (@Comment) {
        my $word_len = length $comm;
        my $next     = $start;
        while ( my $comment = $t->search( -regexp => $comm, $next, $end ) ) {
            $next = "$comment + $word_len chars";

            # Search for a keyword on the same line

            my $from =
              $t->search( -regexp, "\\b\Q$All_Keys\E\\b",
                "$comment linestart" => "$comment lineend" );

            if ( $comment and !$from ) {
                mark_word( $t, $comment, "$comment lineend", 'Comment' );
            }
        }
    }

    foreach my $word (@Red_Keywords) {
        my $word_len = length $word;
        my $next     = $start;
        while ( my $from =
            $t->search( -regexp, "\\b\Q$word\E\\b", $next, $end ) )
        {
            $next = "$from + $word_len chars";

            # Search for a comment character on the same line
            my $comment = $t->search(
                -regexp           => $Comment,
                "$from linestart" => "$from lineend"
            );

            # If comment found and is before keyword, skip formatting
            unless ( $comment and $t->compare( $comment, '<', $from ) ) {
                mark_word( $t, $from, $next, 'Red_Keyword' );
            }

            if ($comment) {
                mark_word( $t, $comment, "$comment lineend", 'Comment' );
            }
        }
    }

    foreach my $word (@Blue_Keywords) {
        my $word_len = length $word;
        my $next     = $start;
        while ( my $from =
            $t->search( -regexp, "\\b\Q$word\E\\b", $next, $end ) )
        {
            $next = "$from + $word_len chars";

            # Search for a comment character on the same line
            my $comment = $t->search(
                -regexp           => $Comment,
                "$from linestart" => "$from lineend"
            );

            # If comment found and is before keyword, skip formatting
            unless ( $comment and $t->compare( $comment, '<', $from ) ) {
                mark_word( $t, $from, $next, 'Blue_Keyword' );
            }

            if ($comment) {
                mark_word( $t, $comment, "$comment lineend", 'Comment' );
            }
        }
    }
}

sub mark_word {
    my $text  = shift;
    my $start = shift;
    my $end   = shift;
    my $style = shift;

    return unless exists $Highlights{$style};

    foreach my $tag ( @{ $Highlights{$style} } ) {
        $text->tagAdd( $tag, $start, $end );
    }
}