The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/local/bin/perl -w

# Test of Tk::ROTextANSIColor
#  This test requires that Tk widgets can be opened
#  This test will launch a Tk widget and write to it using
#  ANSI color codes. Unfortunately, it can not check that the
#  codes were displayed correctly......

# Also tests the tied version

#  In order to do this it simply keeps the window up for a few seconds
#  in case anyone needs to look at it

# Copyright (C) 2010 Tim Jenness
# Copyright (C) 2000 Tim Jenness and the Particle Physics and Astronomy
# Research Council. All Rights Reserved.

use strict;
use Test::More tests => 13;

use Term::ANSIColor;
use Tk;
require_ok( "Tk::ROTextANSIColor" );

# Create new Tk

SKIP: {

my $MW = eval { MainWindow->new() };

# If we have not managed to get a MainWindow that probably
# means we are running headless so skip all remaining tests
skip("Unable to launch Tk MainWindow. Is there a display attached?", 12)
  unless defined $MW;

ok( defined $MW, "MainWindow" );

# Create a simple text wiget

my $text = $MW->ROTextANSIColor->pack;

print "Text $text\n";
isa_ok( $text, "Tk::ROTextANSIColor" );

# We dont want to run an event loop - just do an update
$MW->update;

# Some normal text
doprint($text, "Normal text, no ANSI codes\n");
ok(1, "Printed normal text");

# Some colored text

foreach (qw/ red green blue magenta yellow cyan bold underline /) {
  doprint( $text, colored("This is a test of $_\n", "$_") );
  ok(1, "colored text");
}

# Now try a tie
use vars qw/ *HDL /;
my $tie = tie(*HDL, ref($text), $text);

ok(defined $tie, "Got Tie");

# Cant yet test the return status of a print from a tied text widget
# since it always returns undef (as of v800.021).

print HDL "Some normal text from a tied handle.\n";
print HDL colored("Some tied text in red\n", 'red');

$tie->update;

sleep 3;

}

exit;


# Sub to print a string to the widget and update the display
# could do it with a tied filehandle instead

sub doprint {
  my $text = shift;
  my $str = shift;
  my $ret = $text->insert('end', $str);
  $text->update;
}