Beefy Boxes and Bandwidth Generously Provided by pair Networks
Pathologically Eclectic Rubbish Lister
 
PerlMonks  

Re: Make a Markup Method in Perl?

by zentara (Archbishop)
on May 16, 2012 at 10:09 UTC ( [id://970796]=note: print w/replies, xml ) Need Help??


in reply to Make a Markup Method in Perl?

But does Perl have some kind of module

Any of the GUI toolkits should be able to do it. Here is a basic Tk example. I don't know if it fullfills all your requirements, but the tricks you can do with tags are much more complex than shown here. Look at the second example below for more techniques including Tk::Text's internal regexp search engine.

#!/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__
A more advanced example:
#!/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 proper +ly 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, $en +d ) ) { $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 ); } }

I'm not really a human, but I play one on earth.
Old Perl Programmer Haiku ................... flash japh

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: note [id://970796]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others about the Monastery: (5)
As of 2024-03-28 15:18 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found