File Coverage

blib/lib/Tk/TextANSIColor.pm

Criterion	Covered	Total	%
statement	12	12	100.0
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	16	16	100.0

package Tk::TextANSIColor;

use strict;

require Tk;
require Tk::Text;
require Tk::Font;

use Term::ANSIColor;

use vars qw/ $VERSION /;
$VERSION = '0.15';

# Inherit from Tk::Text
use base qw(Tk::Text);

# Construct the new widget
Construct Tk::Widget 'TextANSIColor';

# Setup some local (my'ed) variables that contain the
# control codes. Set up hashes which have keys of the control
# codes and values containing the actual color (the TAG).
# Currently retrieve these from Term::ANSIColor module.

my (%fgcolors, %bgcolors);
my $clear = color('clear');  # Code to reset control codes

my $code_bold = color('bold');
my $code_uline= color('underline');
my @colors = qw/black red green yellow blue magenta cyan white/;
for (@colors) {
  my $fg = color($_);
  my $bg = color("on_$_");

  $fgcolors{$fg} = "ANSIfg$_";
  $bgcolors{$bg} = "ANSIbg$_";
}


# Initialise class.
# This effectively means create a whole load of Tag shortcuts
# that can be used on this widget

sub InitObject {
  my ($widget, $args) = @_;

  # Initialise base class
  $widget->SUPER::InitObject($args);

  # Setup tags
  # colors
  for (@colors) {
    $widget->tagConfigure("ANSIfg$_", -foreground => $_);
    $widget->tagConfigure("ANSIbg$_", -background => $_);
  }
  # Underline
  $widget->tagConfigure("ANSIul", -underline => 1);
  $widget->tagConfigure("ANSIbd",
			-font => $widget->Font(weight => "bold") );

#  return $widget;
}



# Sub-classed insert method
# We replace ANSI color codes with Text tags

sub insert {

  my $self= shift;  # The widget reference
  my $pos = shift;  # The position to insert
  my @userstuff = @_; # Strings and tags

  # This is the array containing text and tags pairs
  # We pass this to SUPER::insert
  # as (POS, string, [tags], string, [tags]....)
  # insert_array contains string,[tags] pairs
  my @insert_array = ();

  # Need to loop over @userstuff
  # extracting out the text string and any user supplied tags.
  # note that multiple sets of text strings and tags can be supplied
  # as arguments to the insert() method, and we have to process
  # each set in turn.
  # Use an old-fashioned for since we have to extract two items at
  # a time

  for (my $i=0; $i <= $#userstuff; $i += 2) {

    my $text = $userstuff[$i];
    my $utags = $userstuff[$i+1];

    # Store the usertags in an array, expanding the
    # array ref if required
    my @taglist = ();
    if (ref($utags) eq 'ARRAY') {
      @taglist = @{$utags};
    } else {
      @taglist = ($utags);
    }

    # Split the string on control codes
    # returning the codes as well as the strings between
    # the codes
    # Note that this pattern also checks for the case when
    # multiple escape codes are embedded together separated
    # by semi-colons.
    my @split = split /(\e\[(?:\d{1,2};?)+m)/, $text;

    # Array containing the tags to use with the insertion
    # Note that this routine *always* assumes the colors are reset
    # after the last insertion. ie it does not allow the colors to be
    # remembered between calls to insert().
    my @ansitags = ();

    # Current text string
    my $cur_text = undef;

    # Now loop over the split strings
    for my $part (@split) {

      # If we have a plain string, just store it
      if ($part !~ /^\e/) {
	$cur_text = $part;
      } else {
	# We have an escape sequence
	# Need to store the current string with required tags
	# Include the ansi tags and the user-supplied tag list
	push(@insert_array, $cur_text, [@taglist, @ansitags])
	  if defined $cur_text;

	# There is no longer a 'current string'
	$cur_text = undef;

	# The escape sequence can have semi-colon separated bits
	# in it. Need to strip off the \e[ and the m. Split on
	# semi-colon and then reconstruct before comparing
	# We know it matches \e[....m so use substr

	# Only bother if we have a semi-colon

	my @escs = ($part);
	if ($part =~ /;/) {
	  my $strip = substr($part, 2, length($part) - 3);

	  # Split on ; (overwriting @escs)
	  @escs = split(/;/,$strip);

	  # Now attach the correct escape sequence
	  foreach (@escs) { $_ = "\e[${_}m" }
	}

	# Loop over all the escape sequences
	for my $esc (@escs) {

	  # Check what type of escape
	  if ($esc eq $clear) {
	    # Clear all escape sequences
	    @ansitags = ();
	  } elsif (exists $fgcolors{$esc}) {
	    # A foreground color has been specified
	    push(@ansitags, $fgcolors{$esc});
	  } elsif (exists $bgcolors{$esc}) {
	    # A background color
	    push(@ansitags, $bgcolors{$esc});
	  } elsif ($esc eq $code_bold) {
	    # Boldify
	    push(@ansitags, "ANSIbd");
	  } elsif ($esc eq $code_uline) {
	    # underline
	    push(@ansitags, "ANSIul");
	  } else {
	    print "Unrecognised control code - ignoring\n";
	    foreach (split //, $esc) {
	      print ord($_) . ": $_\n";
	    }
	  }

	}
      }
    }

    # If we still have a current string, push that onto the array
    push(@insert_array, $cur_text, [@taglist, @ansitags])
      if defined $cur_text;

  }

  # Finally, insert  the string
  $self->SUPER::insert($pos, @insert_array)
    if $#insert_array > 0;

}

sub getansi {
  my $self= shift;  # The widget reference
  my @args = @_;

  # Indicate whether we are in an ANSI tag
  my $tagflag = 0;

  # Initialise the results string
  my $res = '';

  # Get detailed contents (including tags)
  my @xdump = $self->dump(@args);

  # Loop over the dumped array, incrementing in steps of 3
  for (my $i=0;$i<=$#xdump;$i+=3) {

    # This is a tag. Check to see whether it is for an ANSI
    # control code.
    if ($xdump[$i] eq 'tagon') {

      if ($xdump[$i+1] =~ /^ANSIfg(\w+)/) {

	$res .= color($1);
	$tagflag = 1;

      } elsif ($xdump[$i+1] =~ /^ANSIbg(\w+)/) {

	$res .= color("on_$1");
	$tagflag = 1;

      } elsif ($xdump[$i+1] =~ /^ANSIbd/) {

	$res .= color('bold');
	$tagflag = 1;

      } elsif ($xdump[$i+1] =~ /^ANSIul/) {

	$res .= color('underline');
	$tagflag = 1;

      }

      $res .= $xdump[$i+4]  if ($xdump[$i+3] eq 'text');
    }

    if ($tagflag && $xdump[$i] eq 'tagoff') {

      $res .= color('reset');
      $tagflag = 0;

    } elsif ($i > 3 && $xdump[$i] eq 'text' && $xdump[$i-3] ne 'tagon') {

      $res .= $xdump[$i+1];

    }

  }

  return $res;
}

1;

__END__